Check-in [844ae85b75]
Not logged in

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

Overview
Comment:merge with trunk
Timelines: family | ancestors | descendants | both | wtf-8-experiment
Files: files | file ages | folders
SHA1:844ae85b75c1c25386397fa83ef85b5e9139aa43
User & Date: chw 2019-03-13 09:27:27
Context
2019-03-14
04:57
merge with trunk check-in: b363d961f4 user: chw tags: wtf-8-experiment
2019-03-13
09:27
merge with trunk check-in: 844ae85b75 user: chw tags: wtf-8-experiment
09:18
add selected SDL2 upstream changes check-in: d7125f9b88 user: chw tags: trunk
2019-03-11
07:42
merge with trunk check-in: 606cfc5b36 user: chw tags: wtf-8-experiment
Changes

Changes to assets/tcllib1.19/tepam/tepam.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
...
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
...
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
...
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
...
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
...
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
....
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
....
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
....
1332
1333
1334
1335
1336
1337
1338
1339

1340
1341
1342
1343
1344
1345
1346
....
1351
1352
1353
1354
1355
1356
1357
1358

1359
1360
1361
1362
1363
1364
1365
....
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
....
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
....
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
....
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
....
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
....
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
....
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
....
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
....
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
....
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
....
2141
2142
2143
2144
2145
2146
2147
2148

2149
2150
2151
2152
2153
2154
2155
....
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171

2172
2173
2174
2175
2176
2177
2178
....
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
....
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
....
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
....
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
....
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
....
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
....
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
....
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
....
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
....
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
....
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
....
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
##########################################################################
# TEPAM - Tcl's Enhanced Procedure and Argument Manager
##########################################################################
# tepam.tcl - TEPAM main Tcl package
# 
# TEPAM offers an alternative way to declare Tcl procedures. It provides 
# enhanced argument handling features like automatically generatehd, 
# graphical entry forms and checkers for the procedure arguments.
#
# Copyright (C) 2009/2010/2011 Andreas Drollinger
# 
# Id: tepam.tcl
##########################################################################
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
##########################################################################

package require Tcl 8.3

namespace eval tepam {
   # Exports the major commands from this package:
   namespace export procedure argument_dialogbox

##########################################################################
#                            procedure                                   #
##########################################################################

   ######## Procedure configuration ########
   
   # Set the following variable to 0 (false) prior to the procedure definition, to
   # use first the unnamed arguments and then the named arguments.

   set named_arguments_first 1
   
   # Setting the following variable to 0 will disable the automatic argument name
   # extension feature.
   set auto_argument_name_completion 1

   # Set the following variable prior to the procedure definition to:
   #   - 0 (false): to disable command logging
   #   - 1 (true): to log all commands anytime
   #   - "interactive": to log only interactively called commands
   set command_log "interactive"
   
   # Set the following variable to "short" to generate small interactive dialog boxes.

   set interactive_display_format "extended"

   # The following variable defines the maximum line length a created help text can have:

   set help_line_length 80

   ######## Internal variables ########

   if {![info exists ProcedureList]} {
      set ProcedureList {}
   }

   ######## PureProcName ########

   # PureProcName purifies the procedure name given by the ProcName variable of the calling 
   # function and returns it. PureProcName is basically:
   # * Eliminating the main namespace indicators
   # * Encapsulating the name into '' if it is a composed name
   proc PureProcName {args} {
      upvar ProcName ProcName
      set Name $ProcName
      regsub {^::} $Name {} Name; # Eliminate the main namespace indicators

      if {[lsearch $args -appo]>=0} { # Encapsulate the name into '' if it is a composed name
         set Name "'$Name'"
      }
      return $Name
   }

   ######## Procedure help text ########
   
   set ProcedureHelp {
      procedure <ProcedureName> <ProcedureAttributes> <ProcedureBody>

      <ProcedureAttributes> = {
         [-category <Category>] 
         [-short_description <ShortDescription>]
         [-description <Description>]
         [-return <Return_Type>]
         [-example <Example>]
         [-named_arguments_first 0|1]
         [-command_log 0|1|"interactive"]
         [-auto_argument_name_completion 0|1]
................................................................................
         [-range {<MinValue> <MaxValue>}
         [-multiple]
         [-auxargs <AuxilaryArgumentList>]
         [-auxargs_commands <AuxilaryArgumentCommandList>]
      }

      <ArgumentType> = {
         none double integer alnum alpha ascii control digit graph lower 
         print punct space upper wordchar xdigit color font boolean ""
      }
   }

   # Eliminate leading tabs in the help text and replace eventual tabs through spaces

   regsub -all -line {^\t\t} $ProcedureHelp "" ProcedureHelp
   regsub -all -line {\t} $ProcedureHelp "   " ProcedureHelp

   ######## Procedure ########

   # Procedure allows declaring a new procedure in the TEPAM syntax:
   #
   #    procedure my_proc {
   #       -args {message}
   #    } {
   #       puts $message; # Procedure body
   #    }
   #
   # Procedure creates in fact a TCL procedure with a patched procedure body. This body calls at 

   # the beginning an argument parser (ProcedureArgumentEvaluation) that is reading and validating 
   # the arguments that have been provided to the procedure. The previous lines are for example 
   # creating the following TCL procedure:
   #
   #    proc my_proc {args} {
   #       ::tepam::ProcedureArgumentEvaluation;
   #       if {$ProcedureArgumentEvaluationResult!=""} {
   #          if {$ProcedureArgumentEvaluationResult=="cancel"} return;
   #          return -code error $ProcedureArgumentEvaluationResult;
   #       }
   #       if {$SubProcedure!=""} {return [$SubProcedure]};
   #
   #       puts $message; # Procedure body
   #    }
   #
   # ProcedureArgumentEvaluation uses the TCL procedure args argument to read all the provided
   # arguments. It evaluates first if a sub procedure has to be called. This information and the

   # argument validation result are provided to the calling procedure respectively via the 
   # variables SubProcedure and ProcedureArgumentEvaluationResult. In case the result evaluation
   # was not successful, the calling procedure body will simply return. In case the procedure

   # call refers to a sub-procedure, this one will be called. Otherwise, if a valid argument set
   # has been provided to the procedure, and if no sub-procedure has to be called, the original
   # procedure body is executed.
   # Procedure behaves slightly differently in case one or multiple sub-procedures have been 
   # declared without declaring the main procedure itself:
   #
   #    procedure {my_func sub_func} {
   #       -args {message}
   #    } {
   #       puts $message; # Procedure body
   #    }
   #
   # Procedure creates in this case for the main procedure a Tcl procedure as well as for the sub
   # procedure. The main procedure creates an error when it directly called. The sub-procedure

   # is executed within the main procedure context using the uplevel command.
   #
   #    proc my_proc {args} {
   #       ::tepam::ProcedureArgumentEvaluation;
   #       if {$ProcedureArgumentEvaluationResult!=""} {
   #         if {$ProcedureArgumentEvaluationResult=="cancel"} return;
   #         return -code error $ProcedureArgumentEvaluationResult;
   #       }
   #       if {$SubProcedure!=""} {return [$SubProcedure]};
   #       error "'my_func' requires a subcommand"
   #    }
   #
   #    proc {my_proc sub_func} {args} {
   #       uplevel 1 {
   #          puts $message; # Procedure body
   #       }
   #    }
   #
   # Procedure parses itself the procedure name and attributes and creates the new TCL procedure 
   # with the modified body. For each declared argument it calls ProcedureArgDef which handles the 
   # argument definition.

   proc procedure {args} {
      variable ProcDef
      variable ProcedureHelp
      variable named_arguments_first
      variable command_log
      variable auto_argument_name_completion
................................................................................

         # Check if help is requested:
         if {[lsearch -exact $args "-help"]>=0} {
            puts $ProcedureHelp
            return
         }

         # Check that the procedure name, argument list and body has been provided:

         if {[llength $args]!=3} {
            return -code error "Missing procedure arguments, correct usage: procedure <ProcedureName>\
                   <ProcedureAttributes> <ProcedureBody>"
         }
      
         # Evaluate the full qualified procedure name including a leading name space identifier.

         # Evaluate the current namespace in case the procedure is not defined explicitly with 
         # a name space:
         regsub -all {\s+} [lindex $args 0] " " ProcName
         if {[string range $ProcName 0 1]!="::"} {
            set NameSpace [uplevel 1 {namespace current}]
            if {$NameSpace!="::"} {append NameSpace "::"}
            set ProcName ${NameSpace}${ProcName}
         }

         # Extract the procedure attributes and the procedure body:
         set ProcedureAttributes [lindex $args 1]
         set ProcedureBody [lindex $args 2]

         # Store the procedure name in the procedure list, if it is not already existing:

         if {[lsearch -exact $ProcedureList $ProcName]<0} {
            lappend ProcedureList $ProcName
         }

      #### Initialize the procedure attributes ####

         # Clean the information of an eventual previous procedure definition, and store
         # the actual configured procedure modes:
         catch {array unset ProcDef $ProcName,*}
         set ProcDef($ProcName,-named_arguments_first) $named_arguments_first
         set ProcDef($ProcName,-command_log) $command_log
         set ProcDef($ProcName,-auto_argument_name_completion) $auto_argument_name_completion

         set ProcDef($ProcName,-interactive_display_format) $interactive_display_format


         # The procedure information will be stored in the array variable ProcDef.
         # The following array members are always defined for each declared procedure:

         set ProcDef($ProcName,-validatecommand) {}
         set ProcDef($ProcName,-validatecommand_error_text) {}
         set ProcDef($ProcName,VarList) {}
         set ProcDef($ProcName,NamedVarList) {}
         set ProcDef($ProcName,UnnamedVarList) {}
         #  ProcDef($ProcName,NbrVars); # 
         #  ProcDef($ProcName,NbrNamedVars)
         #  ProcDef($ProcName,NbrUnnamedVars)

         # The following array members are defined optionally in the argument parsing section:

         #  ProcDef($ProcName,$AttributeName)
         #                    | AttributeName = {-category -return -short_description 
         #                    |                  -description -example}
         #
         #  ProcDef($ProcName,Arg,$Var,IsNamed)
         #  ProcDef($ProcName,Arg,$Var,-type)
         #  ProcDef($ProcName,Arg,$Var,-optional)
         #  ProcDef($ProcName,Arg,$Var,-validatecommand)
         #  ProcDef($ProcName,Arg,$Var,-validatecommand_error_text)
................................................................................
         #                    | Contains the choice label list: {<ChoiceLabel1> ... <ChoiceLabelN>}
         #  ProcDef($ProcName,Arg,$Var,-range)
         #  ProcDef($ProcName,Arg,$Var,SectionComment)
         #  ProcDef($ProcName,Arg,$Var,Comment)

      #### Parse all procedure attributes ####

         set UnnamedHasToBeOptional 0; # Variable that will be set to '1' if an unnamed argument is optional.

         set UnnamedWasMultiple 0;     # Variable that will be set to '1' if an unnamed argument has the -multiple option


      
         # Loop through the argument definition list:
         foreach {AttributeName AttributeValue} $ProcedureAttributes {
            # Evaluate the provided argument attribute
            switch -exact -- $AttributeName {

               -help { # Help has been required in the procedure attribute definition list:

                  puts $ProcedureHelp
                  return
               }
               -category -
               -return -
               -short_description -
               -description -
               -named_arguments_first -
               -command_log -
               -auto_argument_name_completion -
               -example -
               -interactive_display_format {
                  # Save all these information simply in the ProcDef array variable:

                  set ProcDef($ProcName,$AttributeName) $AttributeValue
               }
               -validatecommand -
               -validatecommand_error_text {
                  lappend ProcDef($ProcName,$AttributeName) $AttributeValue
               }
               -args {
                  # Read the procedure arguments with ProcedureArgDef
                  set Comment ""
                  set SectionComment ""
                  foreach arg $AttributeValue {
                     set ErrorMsg [ProcedureArgDef $arg]
                     if {$ErrorMsg!=""} {

                        return -code error "Procedure declaration [PureProcName -appo]: $ErrorMsg"
                     }
                  }
               }
               default {

                  return -code error "Procedure declaration [PureProcName -appo]: Procedure attribute '$AttributeName' not known"
               }
            }
         }

         # Complete the procedure attributes -
         # Number of arguments:
         set ProcDef($ProcName,NbrVars) [llength $ProcDef($ProcName,VarList)]
         # Number of named arguments

         set ProcDef($ProcName,NbrNamedVars) [llength $ProcDef($ProcName,NamedVarList)]
         # Number of unnamed arguments

         set ProcDef($ProcName,NbrUnnamedVars) [llength $ProcDef($ProcName,UnnamedVarList)]

      #### Create the TCL procedure(s) ####
      
         # Create now the TCL procedures. In case a sub procedure is declared, the created TCL 

         # procedure has not to call the argument evaluator, since this one has already been called 
         # in the main procedure. An additional main procedure is created if a sub procedure is 
         # declared and if no main procedure is existing.


         set Body    "::tepam::ProcedureArgumentEvaluation;\n"
         append Body "if {\$ProcedureArgumentEvaluationResult!=\"\"} \{\n"
         append Body "  if {\$ProcedureArgumentEvaluationResult==\"cancel\"} return;\n"
         append Body "  return -code error \$ProcedureArgumentEvaluationResult;\n"
         append Body "\}\n"
         append Body "if {\$SubProcedure!=\"\"} {return \[\$SubProcedure\]};\n\n"

         if {[llength $ProcName]==1} {
            append Body "$ProcedureBody"
            proc $ProcName {args} $Body
         } else {
            proc $ProcName {args} "uplevel 1 \{\n$ProcedureBody\n\}"
            if {[info commands [lindex $ProcName 0]]==""} {
               append Body "return -code error \"'[lindex $ProcName 0]' requires a subcommand\""
               proc [lindex $ProcName 0] {args} $Body
            }
         }
   }

   # ProcedureArgDef reads the definition of a single argument that is provided in form of a list:

   #
   #    -mtype -default Warning -choices {Info Warning Error} -description "M. type"
   #
   # ProcedureArgDef is executed by 'procedure'. The argument definition is provided via the 
   # argument 'ArgDef' variable. ProcedureArgDef is recognizing argument comments and section 

   # comments that can be placed into the argument definitions. ProcedureArgDef is also checking 
   # the validity of the argument specifications.

   proc ProcedureArgDef {ArgDef} {
      variable ProcDef
      variable ProcedureHelp
      variable named_arguments_first
      variable command_log
................................................................................
      upvar Comment Comment
      upvar SectionComment SectionComment
      upvar UnnamedHasToBeOptional UnnamedHasToBeOptional
      upvar UnnamedWasMultiple UnnamedWasMultiple

      # Read the argument name:
      set Opt [lindex $ArgDef 0]
         
      #### Handle section and argument comments, parse the option name ####
         
         # Check if the argument definition is a simply argument comment (either -, "" or {})
         if {$Opt=="" || $Opt=="-"} {

            # Eliminate the entire first word as well as any leading and tailing white spaces

            regexp {^\s*[^\s]+\s+(.*)\s*$} $ArgDef {} Comment
            regsub -all "\"" $Comment "\\\"" Comment
            return ""

         # Check if the argument definition is an argument section begin
         } elseif {[string index $Opt 0]=="\#"} {
            # Eliminate leading and tailing white spaces
            set SectionComment [string trim [string range $ArgDef 1 end]]
               
            # Eliminate the leading and ending #s and white spaces
            regexp {^\s*\#+\s*(.*?)\s*\#*\s*$} $ArgDef {} SectionComment
            # regsub -all "\"" $SectionComment "\\\" SectionComment
               
            # For an eventual interactive call that requires a GUI, swap to the short 

            # representation mode, since the frames are used to display the sections:
            set ProcDef($ProcName,-interactive_display_format) "short"
            return ""

         # Check if the argument is an option or a flag (named argument), that has with a 
         # leading '-':
         } elseif {[string index $Opt 0]=="-"} {
            set Var [string range $Opt 1 end]
            lappend ProcDef($ProcName,NamedVarList) $Var
            set ProcDef($ProcName,Arg,$Var,IsNamed) 1
   
         # The argument is an unnamed argument:
         } else {
            set Var $Opt
            lappend ProcDef($ProcName,UnnamedVarList) $Var
            set ProcDef($ProcName,Arg,$Var,IsNamed) 0
         }
         
         # Assign to the argument an eventually previously defined section or argument comment:

         if {$SectionComment!=""} {
            set ProcDef($ProcName,Arg,$Var,SectionComment) $SectionComment
            set SectionComment ""
         }
         if {$Comment!=""} {
            set ProcDef($ProcName,Arg,$Var,Comment) $Comment
            set Comment ""
         }

         # Check that an argument is not declared multiple times:
         if {[lsearch -exact $ProcDef($ProcName,VarList) $Var]>=0} {
            return "Argument '$Var' defined multiple times"
         }

      #### Define the argument attributes ####
         
         # Append the argument to the argument list and define the argument attributes with the
         # default values:
         lappend ProcDef($ProcName,VarList) $Var
         set ProcDef($ProcName,Arg,$Var,-type) ""; # Undefined
         set ProcDef($ProcName,Arg,$Var,-optional) 0
         set ProcDef($ProcName,Arg,$Var,HasDefault) 0
         set ProcDef($ProcName,Arg,$Var,-multiple) 0

         # Parse all argument attribute definitions:
         for {set a 1} {$a<[llength $ArgDef]} {incr a} {
            set ArgOption [lindex $ArgDef $a]
            set ArgOptionValue [lindex $ArgDef [expr {$a+1}]]
            switch -- $ArgOption {
               -type {
                  # Argument type definition: Check if the validation command is defined for 
                  # the used argument type:
                  if {[catch {Validate($ArgOptionValue) ""}]} {
                     return "Argument type '$ArgOptionValue' not known"
                  }
                     
                  # Store the attribute type:
                  set ProcDef($ProcName,Arg,$Var,-type) $ArgOptionValue
                     
                  # Flags (argument that have the type 'none') are always optional:

                  if {$ProcDef($ProcName,Arg,$Var,-type)=="none"} {
                     set ProcDef($ProcName,Arg,$Var,-optional) 1
                  }
                  incr a
               }
   
               -default {
                  # Arguments that have default values are always optional:
                  set ProcDef($ProcName,Arg,$Var,-default) $ArgOptionValue
                  set ProcDef($ProcName,Arg,$Var,HasDefault) 1
                  set ProcDef($ProcName,Arg,$Var,-optional) 1
                  incr a
               }
   

               -mandatory {# The -mandatory attribute is already the default behavior}
   

               -optional -
               -multiple {
                  # These attributes (flags) have just to be stored for future usage:

                  set ProcDef($ProcName,Arg,$Var,$ArgOption) 1
               }
   
               -range {
                  # Check that the range is defined by two values and that the min value is 
                  # smaller than the max value:
                  if {[llength $ArgOptionValue]!=2 || \
                      ![Validate(double) [lindex $ArgOptionValue 0]] || \
                      ![Validate(double) [lindex $ArgOptionValue 1]]} {
                     return  "Invalid range definition - $ArgOptionValue"
                  }
                  set ProcDef($ProcName,Arg,$Var,$ArgOption) $ArgOptionValue
                  incr a
               }
                  
               -validatecommand -
               -validatecommand_error_text -
               -auxargs_commands -
               -auxargs -
               -description -
               -choices -
               -choicelabels -
               -widget {
                  # Also these attributes have just to be stored for future usage:

                  set ProcDef($ProcName,Arg,$Var,$ArgOption) $ArgOptionValue
                  incr a
               }
   
               default {
                  # Generate an error if the provided attribute name doesn't match with a known
                  # attribute.
                  return "Argument attribute '$ArgOption' not known"
               }
            }
         }

      #### Perform various argument attribute validation checks ####

         # Unnamed argument attribute checks:
         if {!$ProcDef($ProcName,Arg,$Var,IsNamed)} {
            # Check that behind an optional unnamed argumeent there are only other optional 
            # unnamed arguments:
            if {$UnnamedHasToBeOptional && !$ProcDef($ProcName,Arg,$Var,-optional)} {
               return "Argument '$Var' has to be optional"
            }
               
            # Check that only the last unnamed argument can take multiple values:

            if {$UnnamedWasMultiple} {
               return "Attribute '-multiple' is only for the last unnamed argument allowed"
            }
               
            # Check the length of an optional -choicelabels list
            if {[info exists ProcDef($ProcName,Arg,$Var,-choices)] && \
                [info exists ProcDef($ProcName,Arg,$Var,-choicelabels)]} {
               if {[llength $ProcDef($ProcName,Arg,$Var,-choices)]!=
                   [llength $ProcDef($ProcName,Arg,$Var,-choicelabels)]} {
                  return "Argument '$Var' - Choice label list and choice list have different sizes"
               }
            }
               
            # Store the information about the argument attributes the check the consistency of 
            # the following arguments:
            if {$ProcDef($ProcName,Arg,$Var,-optional)} {
               set UnnamedHasToBeOptional 1
            }
            if {$ProcDef($ProcName,Arg,$Var,-multiple)} {
               set UnnamedWasMultiple 1
            }
         }
                     
         # Range checks are only allowed for integers and doubles:
         if {[info exists ProcDef($ProcName,Arg,$Var,-range)]} {
            if {[lsearch {integer double} $ProcDef($ProcName,Arg,$Var,-type)]<0} {
               return "Argument '$Var' - range specification requires type integer or double"
            }
         }

      return ""
   }

   ######## ProcedureArgumentEvaluation ########

   # ProcedureArgumentEvaluation is the argument evaluator that is embedded by the procedure

   # declaration command 'procedure' into the procedure body in the following way:
   #
   #    proc my_proc {args} {
   #       ::tepam::ProcedureArgumentEvaluation;
   #       if {$ProcedureArgumentEvaluationResult!=""} {
   #         if {$ProcedureArgumentEvaluationResult=="cancel"} return;
   #         return -code error $ProcedureArgumentEvaluationResult;
   #       }
   #       if {$SubProcedure!=""} {return [$SubProcedure]};
   #
   #       puts $message; # Procedure body
   #    }
   #
   # ProcedureArgumentEvaluation has to define in the calling procedure two variables: 

   # The first one is ProcedureArgumentEvaluationResult that has to contain the result of the 

   # evaluation and validation of the argument set. Zero as results means that the provided 
   # arguments are OK and that the procedure body can be executed. A non-zero value indicates 
   # that the procedure body has not to be evaluated, typically because help was requested via
   # the -help option. In case of incorrect arguments an error is generated by 
   # ProcedureArgumentEvaluation.
   # The second variable that is created by ProcedureArgumentEvaluation is 'SubProcedure'. This

   # variable is set to the sub procedure name in case a sub procedure is called. If the main
   # procedure is called this variable is set to an empty string.


   # Delcare first a tiny helper function: ProcedureArgumentEvaluationReturn will assign the 
   # provided result string to the ProcedureArgumentEvaluationResult variable in the context

   # of the calling procedure and will then emulate a return function.

   proc ProcedureArgumentEvaluationReturn {Result} {
      upvar 2 ProcedureArgumentEvaluationResult ProcedureArgumentEvaluationResult

      set ProcedureArgumentEvaluationResult $Result
      return -code return
   }

   proc ProcedureArgumentEvaluation {} {
      variable ProcDef
      upvar args args
      upvar SubProcedure SubProcedure

      #### Extract the procedure and sub procedure names, call the procedure help if requested ####

         # Evaluate the complete main procedure name that contains the namespace identification:

         # The procedure name is given by the first element of 'info level':
         set ProcedureCallLine [info level -1]
         set ProcName [lindex $ProcedureCallLine 0]

         # Create the full qualified procedure name (procedure name including namespace)

         regexp {([^:]*)$} $ProcName {} ProcName
         set NameSpace [uplevel 1 {namespace current}]
         if {$NameSpace!="::"} {append NameSpace "::"}
         set ProcName ${NameSpace}${ProcName}

         # Evaluate the sub command names by checking if the first arguments are matching with
         # a specified sub command name:
         set SubProcedure ""
         while {1} {
            set ProcNameTmp "$ProcName [lindex $args 0]"
            if {![info exists ProcDef($ProcNameTmp,VarList)] && [array names ProcDef "$ProcNameTmp *"]==""} {
               # The argument is not matching with a specified sub command name (so it will be a
               # real argument):
               break
            }
            # Use the argument as sub procedure name:
            set ProcName $ProcNameTmp
            set SubProcedure $ProcName
            set args [lrange $args 1 end]
         }

         # Check if help has been requested in the procedure call:
         if {[lindex $args end]=="-help"} {
            ProcedureHelp $ProcName
            ProcedureArgumentEvaluationReturn "cancel"
         }

         # Check if the procedure call is an interactive call
         set InteractiveCall [string match "-interactive" [lindex $args end]]

         # Return an empty string if the main procedure has been called and if only sub-commands 

         # have been defined, but not the main procedure itself.
         if {![info exists ProcDef($ProcName,VarList)]} {
            ProcedureArgumentEvaluationReturn ""
         }

      #### Call an argument_dialogbox if the procedure has been called with '-interactive' ####
         set NewArgs {}
         if {$InteractiveCall} {
            # Generate an error if Tk hasn't been loaded
            if {[catch {package present Tk}]} {

               ProcedureArgumentEvaluationReturn "[PureProcName]: Interactive calls are only supported if Tk is loaded!"
            }


            # Start creating the argument_dialogbox argument list with the title attribute:

            set DialogBoxArguments [list -title $ProcName -context $ProcName]

            # Add eventual global validation commands
            foreach ValidateCommand $ProcDef($ProcName,-validatecommand) {
               lappend DialogBoxArguments -validatecommand2 $ValidateCommand
            }

            foreach ValidateCommandErrorText $ProcDef($ProcName,-validatecommand_error_text) {

               lappend DialogBoxArguments -validatecommand2_error_text $ValidateCommandErrorText
            }

            # Create for each of the procedure arguments an entry for the argument_dialogbox:

            foreach Var $ProcDef($ProcName,VarList) {
               # Declare the result variables. These variables refer to the variables in the parent 

               # procedure (upvar). Attribute to these variables directly the default values that can be 
               # overwritten later with the new defined values.
               upvar $Var Variable__$Var

               # Create sections, write section and argument comments:
               if {$ProcDef($ProcName,-interactive_display_format)=="extended"} {
                  if {[info exists ProcDef($ProcName,Arg,$Var,SectionComment)]} {
                     # If a section comment is defined, close an eventual open frame, add the 

                     # section comment and add an eventually defined arguement comment:

                     lappend DialogBoxArguments -frame ""; # Close an eventual open frame
                     lappend DialogBoxArguments \
                                 -comment [list -text $ProcDef($ProcName,Arg,$Var,SectionComment)]
                     if {[info exists ProcDef($ProcName,Arg,$Var,Comment)]} {
                        lappend DialogBoxArguments \
                                    -comment [list -text $ProcDef($ProcName,Arg,$Var,Comment)]
                     }
                  }
                  # Create a frame around each argument entry in the extended format:

                  lappend DialogBoxArguments -frame [list -label $Var]
               } elseif {[info exists ProcDef($ProcName,Arg,$Var,SectionComment)]} {
                  # If a section is defined, create a section frame in the sort format:

                  lappend DialogBoxArguments \
                              -frame [list -label $ProcDef($ProcName,Arg,$Var,SectionComment)]
               }
               # If an argument comment is defined but not yet applied, apply it: 

               if {[info exists ProcDef($ProcName,Arg,$Var,Comment)] &&
                   !( $ProcDef($ProcName,-interactive_display_format)=="extended" &&
                     [info exists ProcDef($ProcName,Arg,$Var,SectionComment)] )} {
                  lappend DialogBoxArguments \
                              -comment [list -text $ProcDef($ProcName,Arg,$Var,Comment)]
               }

               # Provide to the argument dialogbox all the argument attributes:
               set ArgAttributes {}
               if {$ProcDef($ProcName,Arg,$Var,-type)!=""} {
                  lappend ArgAttributes -type $ProcDef($ProcName,Arg,$Var,-type)
               }
               if {$ProcDef($ProcName,Arg,$Var,-optional)} {
                  lappend ArgAttributes -optional 1
               }
               if {[info exists ProcDef($ProcName,Arg,$Var,-range)] && \
                   $ProcDef($ProcName,Arg,$Var,-range)!=""} {
                  lappend ArgAttributes -range $ProcDef($ProcName,Arg,$Var,-range)
               }
               if {[info exists ProcDef($ProcName,Arg,$Var,-validatecommand)]} {
                  lappend ArgAttributes -validatecommand $ProcDef($ProcName,Arg,$Var,-validatecommand)
               }
               if {[info exists ProcDef($ProcName,Arg,$Var,-validatecommand_error_text)]} {
                  lappend ArgAttributes -validatecommand_error_text $ProcDef($ProcName,Arg,$Var,-validatecommand_error_text)
               }
               if {[info exists ProcDef($ProcName,Arg,$Var,-auxargs)] && $ProcDef($ProcName,Arg,$Var,-auxargs)!=""} {
                  set ArgAttributes [concat $ArgAttributes $ProcDef($ProcName,Arg,$Var,-auxargs)]
               }
               if {[info exists ProcDef($ProcName,Arg,$Var,-auxargs_commands)]} {
                  foreach {AuxArg_Name AuxArgCommand} $ProcDef($ProcName,Arg,$Var,-auxargs_commands) {
                     lappend ArgAttributes $AuxArg_Name [uplevel #1 $AuxArgCommand]
                  }
               }
................................................................................
               }

               # Set the default values
               if {[info exists ProcDef($ProcName,Arg,$Var,-default)]} {
                  lappend ArgAttributes -default $ProcDef($ProcName,Arg,$Var,-default)
               }

               # Add the variable name, type, description and range as labels and comments:

               set Label $Var; # Default label
               if {$ProcDef($ProcName,-interactive_display_format)=="extended"} {
                  # Add the argument description as comment
                  if {[info exists ProcDef($ProcName,Arg,$Var,-description)]} {
                     lappend DialogBoxArguments \
                                    -comment [list -text $ProcDef($ProcName,Arg,$Var,-description)]
                  }

                  # Add the type and ranges as comment
                  if {[lsearch {"" "string" "none"} $ProcDef($ProcName,Arg,$Var,-type)]<0} {
                     set Comment "Type: $ProcDef($ProcName,Arg,$Var,-type), "
                     if {[info exists ProcDef($ProcName,Arg,$Var,-range)]} {
                        append Comment "range: [lindex $ProcDef($ProcName,Arg,$Var,-range) 0] .. \
                                                [lindex $ProcDef($ProcName,Arg,$Var,-range) 1], "
                     }
                     lappend DialogBoxArguments -comment [list -text [string range $Comment 0 end-2]]
                  }
               } else {
                  if {[info exists ProcDef($ProcName,Arg,$Var,-description)]} {
                     set Label $ProcDef($ProcName,Arg,$Var,-description)
                  }
               }
               
               # Select the adequate widget for the argument:
               lappend ArgAttributes -label "$Label:" -variable Variable__$Var

               # A specific entry widget is explicitly specified:
               if {[info exists ProcDef($ProcName,Arg,$Var,-widget)]} {

                  lappend DialogBoxArguments -$ProcDef($ProcName,Arg,$Var,-widget) $ArgAttributes

               # A type specific widget exists, so use this one:
               } elseif {[info procs ad_form($ProcDef($ProcName,Arg,$Var,-type))]!=""} {
                  lappend DialogBoxArguments -$ProcDef($ProcName,Arg,$Var,-type) $ArgAttributes

               # Use a simple checkbutton for flags:
               } elseif {$ProcDef($ProcName,Arg,$Var,-type)=="none"} {
                  lappend DialogBoxArguments -checkbutton $ArgAttributes

               # A choice list is provided with less or equal than 4 options, use radioboxes or checkboxes:

               } elseif {[info exists ProcDef($ProcName,Arg,$Var,-choices)] && \
                   [llength $ProcDef($ProcName,Arg,$Var,-choices)]<=4} {
                  if {$ProcDef($ProcName,Arg,$Var,-multiple)} {
                     lappend DialogBoxArguments -checkbox [concat [list \
                                 -choices $ProcDef($ProcName,Arg,$Var,-choices)] $ArgAttributes]
                  } else {
                     lappend DialogBoxArguments -radiobox [concat [list \
                                 -choices $ProcDef($ProcName,Arg,$Var,-choices)] $ArgAttributes]
                  }

               # A choice list is provided with less than 30 options, use a listbox or a disjointlistbox:

               } elseif {[info exists ProcDef($ProcName,Arg,$Var,-choices)] && \
                         [llength $ProcDef($ProcName,Arg,$Var,-choices)]<30} {
                  if {$ProcDef($ProcName,Arg,$Var,-multiple)} {
                     lappend DialogBoxArguments -disjointlistbox [concat [list \
                                 -choicevariable ProcDef($ProcName,Arg,$Var,-choices) -height 3] $ArgAttributes]

                  } else {
                     lappend DialogBoxArguments -listbox [concat [list \
                                 -choicevariable ProcDef($ProcName,Arg,$Var,-choices) -height 3] $ArgAttributes]

                  }

               # For all other cases, use a simple entry widget:
               } else {
                  lappend DialogBoxArguments -entry $ArgAttributes
               }
            }

            # Call the argument dialogbox
            # puts "argument_dialogbox \{$DialogBoxArguments\}"
            if {[argument_dialogbox $DialogBoxArguments]=="cancel"} {
               # The argument dialogbox has been canceled, leave the calling procedure without
               # executing the procedure body:
               ProcedureArgumentEvaluationReturn cancel
            }

            # Set the variables of the optional arguments to the default values, if the variables

            # haven't been defined by the argument dialogbox:
            foreach Var $ProcDef($ProcName,VarList) {
               if {![info exists Variable__$Var] && \
                    [info exists ProcDef($ProcName,Arg,$Var,-default)]} {
                     set Variable__$Var $ProcDef($ProcName,Arg,$Var,-default)
               }
            }

      #### Non interactive call: Parse all arguments and define the argument variables ####

         } else {

            # Result variable declaration and default value definition
            foreach Var $ProcDef($ProcName,VarList) {
               # Declare the result variables. These variables refer to the variables in the parent 

               # procedure (upvar). Attribute to these variables directly the default values that can be 
               # overwritten later with the new defined values.

               upvar $Var Variable__$Var

               # Set the flags to the default values only when the procedure is called interactively:

               if {$ProcDef($ProcName,Arg,$Var,-type)=="none"} {
                  set Variable__$Var 0
               } elseif {[info exists ProcDef($ProcName,Arg,$Var,-default)]} {
                  # Apply an eventually defined default value, in case the argument is not a flag:

                  set Variable__$Var $ProcDef($ProcName,Arg,$Var,-default)
               }
            }

            # Prepare parsing all arguments
            set NbrArgs [llength $args]; # Number of provided arguments
            set NumberUnnamedArgs 0
            set ArgPos 0

            # Parse the unnamed arguments if they are defined first and if some of them have been 
            # declared:
            if {!$ProcDef($ProcName,-named_arguments_first)} {
               # Parse all unnamed arguments. Stop parsing them when:
               # 1) all unnamed arguments that have been declared have been parsed &&
               #    the last unnamed argument has not the -multiple option &&

               # 2) the parsed argument is optional and starts with '-'
               # 3) the parsed argument has can take multiple values &&
               #    one value has already been read &&
               #    the parsed argument starts with '-'
               
               # An argument value is optional when it has been declared with the -optional option

               # or when it is declared with the -multiple option and already one value has been
               # attributed to the argument:
               set IsOptional 0
               
               # Loop through all arguments (only if unnamed arguments have been declared:

               for {} {$ArgPos<[llength $args] && $ProcDef($ProcName,NbrUnnamedVars)>0} {incr ArgPos} {
                  # Get the next provided parameter value:
                  set arg [lindex $args $ArgPos]
                  
                  # The ordered unnamed argument list provides the relevant argument:

                  set Var [lindex $ProcDef($ProcName,UnnamedVarList) $NumberUnnamedArgs]
                  
                  # Stop parsing the unnamed arguments, if the procedure has also named arguments, 

                  # if the argument to parse is optional, and if it starts with '-':
                  if {$ProcDef($ProcName,Arg,$Var,-optional)} {
                     set IsOptional 1
                  }
                  if {$ProcDef($ProcName,NbrNamedVars)>0 && $IsOptional && \
                      [string index $arg 0]=="-"} {
                     break
                  }

                  # If the argument can have multiple values: Don't update the unnamed argument 

                  # counter to attribute the next values to the same argument. Declare the next
                  # values also as optional
                  if {$ProcDef($ProcName,Arg,$Var,-multiple)} {
                     lappend Variable__$Var $arg
                     set IsOptional 1

                  # Otherwise (the argument cannot have multiple values), assign the value to the

                  # variable. Exit the unnamed argument loop when the last declared argument has
                  # been read:
                  } else {
                     set Variable__$Var $arg
                     incr NumberUnnamedArgs
                     if {$NumberUnnamedArgs==$ProcDef($ProcName,NbrUnnamedVars)} {
                        incr ArgPos
                        break
                     }
                  }
               }
               
               # Create an error if there are other argument values that are provided, but when no
               # named arguments are declared:
               if {$ProcDef($ProcName,NbrNamedVars)==0 && $ArgPos<[llength $args]} {

                  ProcedureArgumentEvaluationReturn "$ProcName: Too many arguments: [lrange $args $ArgPos end]"
               }
            }

            # Parse the named arguments
            for {} {$ArgPos<[llength $args]} {incr ArgPos} {
               # Get the argument name:
               set arg [lindex $args $ArgPos]

               # Ignore the '--' flag. Exit the named argument parsing loop if 'named arguments
               # first' is configured
               if {$arg=="--"} {
                  if {$ProcDef($ProcName,-named_arguments_first)} {
                     incr ArgPos
                     break
                  } else {
                     continue
                  }
               }

               # In case the named arguments are used first: Check if the next argument is not 

               # anymore a named argument and stop parsing the named arguments if this is the case.
               if {$ProcDef($ProcName,-named_arguments_first) && [string index $arg 0]!="-"} {
                  break
               }

               # Otherwise (especially if the unnamed arguments are used first), check that the
               # option name starts with '-':
               if {[string index $arg 0]!="-"} {

                  ProcedureArgumentEvaluationReturn "[PureProcName]: Argument '$arg' is not an option"
               }

               # Extract the variable name (eliminate the '-'):
               set Var [string range $arg 1 end]

               # Check if the variable (name) is known. When it is not known, complete it when the 

               # name matches with the begin of a known variable name, or generate otherwise an 
               # error:
               if {![info exists ProcDef($ProcName,Arg,$Var,-type)]} {
                  
                  # Argument completion is disabled - generate an error:
                  if {!$ProcDef($ProcName,-auto_argument_name_completion)} {

                     ProcedureArgumentEvaluationReturn "[PureProcName -appr]: Argument '-$Var' not known"
                  
                  # Argument completion is enabled - check if the variable name corresponds to the
                  # begin of a known argument name:
                  } else {
                     # set MatchingVarList [lsearch -all -inline -glob $ProcDef($ProcName,VarList) ${Var}*] -> Tcl 8.3 doesn't support the -all and -inline switches!
                     set MatchingVarList {}
                     set VarList $ProcDef($ProcName,VarList)
                     while {[set Pos [lsearch -glob $VarList ${Var}*]]>=0} {
                        lappend MatchingVarList [lindex $VarList $Pos]
                        set VarList [lrange $VarList [expr $Pos+1] end]
                     }

                     # Complete the argument name if the argument doesn't exist, but if it is the begin of a declared argument.
                     switch [llength $MatchingVarList] {

                        1 {set Var $MatchingVarList}



                        0 {ProcedureArgumentEvaluationReturn "[PureProcName]: Argument '-$Var' not known"}



                        default {ProcedureArgumentEvaluationReturn "[PureProcName]: Argument '-$Var' may match multiple options: $MatchingVarList"}

                     }
                  }
               }
                  
               # Set the variable value to '1' if the argument is a flag (type=='none'). Read 
               # otherwise the variable value:
               if {$ProcDef($ProcName,Arg,$Var,-type)=="none"} { # The argument is a flag

                  set Value 1
               
               # No argument value is provided - generate an error:
               } elseif {$ArgPos==[llength $args]-1} {

                  ProcedureArgumentEvaluationReturn "[PureProcName]: No value is provided for argument '-$Var'"

               # Read the argument value
               } else {
                  set Value [lindex $args [incr ArgPos]]
               }

               # Define the argument variable. Append the new value to the existing value of the

               # variable, if the '-multiple' attribute is set for the argument:
               if {$ProcDef($ProcName,Arg,$Var,-multiple)} {
                  lappend Variable__$Var $Value
               } else {
                  set Variable__$Var $Value
               }
            }

            # In case the unnamed arguments are defined last, parse them now:
            if {$ProcDef($ProcName,-named_arguments_first)} {
               
               # Loop through the remaining arguments:
               for {} {$ArgPos<[llength $args]} {incr ArgPos} {
                  # Get the next provided parameter value:
                  set arg [lindex $args $ArgPos]
                  # Assure that the number of provided arguments is not exceeding the total number
                  # of declared unnamed arguments:
                  if {$NumberUnnamedArgs>=$ProcDef($ProcName,NbrUnnamedVars)} {
                     # Too many unnamed arguments are used, generate an adequate error message:

                     if {[string index $arg 0]=="-"} {

                        ProcedureArgumentEvaluationReturn "[PureProcName]: Too many unnamed arguments, or incorrectly used named argument: $arg"
                     } else {

                        ProcedureArgumentEvaluationReturn "[PureProcName]: Too many unnamed arguments: $arg"
                     }
                  }
                  
                  # The ordered unnamed argument list provides the relevant argument:

                  set Var [lindex $ProcDef($ProcName,UnnamedVarList) $NumberUnnamedArgs]

                  # Assign all remaining parameter values to the last argument if this one can 
                  # take multiple values:
                  if {$ProcDef($ProcName,Arg,$Var,-multiple) && \
                     $NumberUnnamedArgs==$ProcDef($ProcName,NbrUnnamedVars)-1} {
                     set Variable__$Var [lrange $args $ArgPos end]
                     # incr NumberUnnamedArgs
                     set ArgPos [llength $args]

                  # Assign otherwise the parameter value to the actual argument
                  } else {
                     set Variable__$Var $arg
................................................................................
                  }
               }
            }
         }

      #### Argument validation ####

         # Check that all mandatory arguments have been defined and that all arguments satisfy the 
         # defined type:

         # Loop through all named and unnamed arguments:
         foreach Var $ProcDef($ProcName,VarList) {
            
            # An error is created when a variable is not optional and when it is not defined:

            if {!$ProcDef($ProcName,Arg,$Var,-optional) && ![info exists Variable__$Var]} {

               ProcedureArgumentEvaluationReturn "[PureProcName]: Required argument is missing: $Var"
            }
            
            # Check the variable value corresponds to the specified type:
            if {[info exists Variable__$Var]} {
               # Transform the variable value in a list in case the argument is not multiple 
               # definable:
               set ValueList [set Variable__$Var]
               if {!$ProcDef($ProcName,Arg,$Var,-multiple)} {
                  set ValueList [list $ValueList]
               }

               # Loop through all elements of this list and check if each element is valid:

               foreach Value $ValueList {
                  # Check the argument type:
                  if {![Validate($ProcDef($ProcName,Arg,$Var,-type)) $Value]} {

                     ProcedureArgumentEvaluationReturn "[PureProcName]: Argument '$Var' requires type '$ProcDef($ProcName,Arg,$Var,-type)'. Provided value: '$Value'"
                  }
               
                  # Check the argument with an eventually defined validation command:

                  if {[info exists ProcDef($ProcName,Arg,$Var,-validatecommand)]} {
                     regsub {%P} $ProcDef($ProcName,Arg,$Var,-validatecommand) $Value ValidateCommand
                     if {![uplevel $ValidateCommand]} {
                        if {[info exists ProcDef($ProcName,Arg,$Var,-validatecommand_error_text)]} {

                           ProcedureArgumentEvaluationReturn "[PureProcName]: $ProcDef($ProcName,Arg,$Var,-validatecommand_error_text)"
                        } else {

                           ProcedureArgumentEvaluationReturn "[PureProcName]: Argument '$Var' is invalid. Provided value: '$Value'. Constraint: '$ProcDef($ProcName,Arg,$Var,-validatecommand)'"
                        }
                     }
                  }

                  # Check if the variable value satisfies an eventually defined range:

                  if {[info exists ProcDef($ProcName,Arg,$Var,-range)]} {
                     if {$Value<[lindex $ProcDef($ProcName,Arg,$Var,-range) 0] || \
                         $Value>[lindex $ProcDef($ProcName,Arg,$Var,-range) 1]} {

                        ProcedureArgumentEvaluationReturn "[PureProcName]: Argument '$Var' has to be between [lindex $ProcDef($ProcName,Arg,$Var,-range) 0] and [lindex $ProcDef($ProcName,Arg,$Var,-range) 1]"
                     }
                  }

                  # Check the variable value is a member of a provided choice list:

                  if {[info exists ProcDef($ProcName,Arg,$Var,-choices)]} {
                     if {[lsearch -exact $ProcDef($ProcName,Arg,$Var,-choices) $Value]<0} {

                        ProcedureArgumentEvaluationReturn "[PureProcName]: Argument '$Var' has to be one of the following elements: [GetChoiceHelpText $ProcName $Var]"
                     }
                  }
               }
            }
         }

      #### Procedure level validation ####


         foreach ValidateCommand $ProcDef($ProcName,-validatecommand) ValidateCommandErrorText $ProcDef($ProcName,-validatecommand_error_text) {
            # regsub {%P} $ProcDef($ProcName,Arg,$Var,-validatecommand) $Value ValidateCommand
            if {![uplevel $ValidateCommand]} {
               if {$ValidateCommandErrorText!=""} {

                  ProcedureArgumentEvaluationReturn "[PureProcName]: $ValidateCommandErrorText"
               } else {

                  ProcedureArgumentEvaluationReturn "[PureProcName]: Invalid argument(s) provided. Constraint: '$ValidateCommand'"
               }
            }
         }

      #### Log the procedure call ####
      
         variable ProcedureCallLogList

         if {$InteractiveCall && $ProcDef($ProcName,-command_log)=="interactive"} {
            append ProcedureCallLogList $ProcName
            if {$ProcDef($ProcName,-named_arguments_first)} {
               set ParClasses {Named Unnamed}
            } else {
               set ParClasses {Unnamed Named}
            }
            foreach ParClass $ParClasses {
               foreach Var $ProcDef($ProcName,${ParClass}VarList) {
                  if {![info exists Variable__$Var]} continue; # Skip optional arguments that haven't been defined
                  if {$ProcDef($ProcName,Arg,$Var,-type)!="none"} { # Non flag arguments
                     if {$ProcDef($ProcName,Arg,$Var,IsNamed)} {
                        append ProcedureCallLogList " -$Var"
                     }
                     append ProcedureCallLogList " \{[set Variable__$Var]\}"
                  } elseif {[set Variable__$Var]} { # Flags that are set
                     append ProcedureCallLogList " -$Var"
                  }
               }
            }
            append ProcedureCallLogList "; \# interactive call\n"
         } elseif {$ProcDef($ProcName,-command_log)=="1"} {
            append ProcedureCallLogList "$ProcedureCallLine\n"
         }
      
      ProcedureArgumentEvaluationReturn ""
   }

   ######## Validation commands ########
   
   # For each of the standard argument types supported by TEPAM, the validation command 

   # 'Validate(<Type>)' specified in the following section. These commands have to return '1' in
   # case the provided value correspond to the relevant type and '0' if not. Additional user or

   # application specific types can easily be supported simply by adding a validation command
   # for the new type into the 'tepam' namespace.

   proc Validate()         {v} {return 1}
   proc Validate(none)     {v} {return 1}
   proc Validate(string)   {v} {return 1}
   proc Validate(text)     {v} {return 1}
   proc Validate(boolean)  {v} {string is boolean -strict $v}
................................................................................
   proc Validate(lower)    {v} {string is lower $v}
   proc Validate(print)    {v} {string is print $v}
   proc Validate(punct)    {v} {string is punct $v}
   proc Validate(space)    {v} {string is space $v}
   proc Validate(upper)    {v} {string is upper $v}
   proc Validate(wordchar) {v} {string is wordchar $v}
   proc Validate(xdigit)   {v} {string is xdigit $v}
   proc Validate(char)     {v} {expr [string length $v]==1}
   proc Validate(color)    {v} {expr ![catch {winfo rgb . $v}]}
   proc Validate(font)     {v} {expr ![catch {font measure $v ""}]}
   proc Validate(file)              {v} {expr [string length $v]>0 && ![regexp {[\"*?<>]} $v]}
   proc Validate(existingfile)      {v} {file exists $v}
   proc Validate(directory)         {v} {return 1}
   proc Validate(existingdirectory) {v} {file isdirectory $v}

   ######## Help text generation ########

   # 'ProcedureHelp_Append' appends a piece of text to the existing HelpText variable of the 

   # calling context (procedure). Tabulator characters are replaced through 3 spaces. Lines are 
   # reformatted to respect the maximum allowed line length. In case a line is wrapped, the leading

   # spaces of the first line are added to the begin of the following lines. Multiple lines can be
   # provided as text piece and these multiple lines are handled independently each to another.


   proc ProcedureHelp_Append {Text} {
      upvar HelpText HelpText
      variable help_line_length
      
      # Replace tabs through 3 spaces:
      regsub -all {\t} $Text "   " Text
      
      # Extract the initial spaces of the first line:
      regexp {^(\s*)} $Text {} SpaceStart
      
      # Loop through each of the provided help text line:
      foreach line [split $Text "\n"] {
         
         # Eliminate leading spaces of the line:
         regexp {^\s+'*(.*)$} $line {} line
         
         # Cut the line into segments that doesn't exceed the maximum allowed help line length. 

         # Add in front of each new line the initial spaces of the first line:
         while {$line!=""} {
            # Align the leading line spaces to the first line:
            set line ${SpaceStart}${line}
            
            #### Next line cutoff position evaluation ####

            # Select the next line cut position. The default position is set to the line end:

            set LastPos [string length $line]
            # Search for the last space inside the line section that is inside the specified 
            # maximum line length:
            if {$LastPos>$help_line_length} {
               set LastPos [string last " " $line $help_line_length]
            }
            # If the evaluated line break position is inside the range of the initial line spaces,

            # something goes wrong and the line should be broken at another adequate character:
            if {$LastPos<=[string length $SpaceStart]-1} {
               # Search for other good line break characters (:
               set LastPos [lindex [lindex \
                  [regexp -inline -indices {[^,:\.?\)]+$} \
                  {ProcDef(::ImportTestPointAssignmentsGeneric,Arg_SectionComment,ColumnSeparation}] 0] 0]
               # No line break position could be found:
               if {$LastPos=={}} {set LinePos 0}
            }
            # Break the line simply at the maximum allowed length in case no break position could 
            # be found:
            if {$LastPos<=[string length $SpaceStart]-1} {set LastPos $help_line_length}



            # Add the line segment to the help text:
            append HelpText [string range $line 0 [expr $LastPos-1]]\n
            
            # Eliminate the segment from the actual line:
            set line [string range $line [expr $LastPos+1] end]
         }
      }
   }

   # GetChoiceHelpText returns a help text for the choice options. The returned string corresponds

   # to the comma separated choice list in case no choice labels are defined. Otherwise, the 
   # choice labels are added behind the choice options in paranthesis.
   
   proc GetChoiceHelpText {ProcName Var} {
      variable ProcDef
      set ChoiceHelpText ""
      set LabelList {}
      catch {set LabelList $ProcDef($ProcName,Arg,$Var,-choicelabels)}
      foreach Choice $ProcDef($ProcName,Arg,$Var,-choices) Label $LabelList {
         append ChoiceHelpText ", $Choice"
         if {$Label!=""} {
            append ChoiceHelpText "($Label)"
         }
      }
      return [string range $ChoiceHelpText 2 end]
   }

   # 'ProcedureHelp' behaves in different ways, depending the provided argument. Called without any

   # argument, it summarizes all the declared procedures without explaining details about the 
   # procedure arguments. Called with a particular procedure name as parameter, it produces for

   # this procedure a comprehensive help text. And finally, if it is called with the name of a main 
   # procedure that has multiple sub procedures, it generates for all the sub procedures the 
   # complete help text.

   proc ProcedureHelp {{ProcName ""} {ReturnHelp 0}} {
      variable ProcDef
      variable ProcedureList
      ProcedureHelp_Append "NAME"
      
      # Print a list of available commands when no procedure name has been provided as argument:

      if {$ProcName==""} {
         foreach ProcName [lsort -dictionary $ProcedureList] {
            if {[info exists ProcDef($ProcName,-short_description)]} {
               ProcedureHelp_Append "      [PureProcName] - $ProcDef($ProcName,-short_description)"
            } else {
               ProcedureHelp_Append "      [PureProcName]"
            }
         }

      # A procedure name has been provided, generate a detailed help text for this procedure, or

      # for all sub procedures if only the main procedure names has been provided:
      } else {
         # Create the full qualified procedure name (procedure name including namespace).

         # Check if the procedure name contains already the name space identification:
         if {[string range $ProcName 0 1]!="::"} {
            # The namespace is not part of the used procedure name call. Evaluate it explicitly:

            set NameSpace [uplevel 1 {namespace current}]
            if {$NameSpace!="::"} {append NameSpace "::"}
            set ProcName ${NameSpace}${ProcName}
         }
         set PureProcName [PureProcName]

         # Add the short description if it exists to the NAME help text section. Please note that

         # only the short description of a main procedure is used in case the procedure has also
         # sub procedures.
         if {[info exists ProcDef($ProcName,-short_description)]} {
            ProcedureHelp_Append "      $PureProcName - $ProcDef($ProcName,-short_description)"
         } else {
            ProcedureHelp_Append "      $PureProcName"
         }

         # Create the SYNOPSIS section which contains also the synopsis of eventual sub procedures:

         ProcedureHelp_Append "SYNOPSIS"
         set NbrDescriptions 0
         set NbrExamples 0
         
         # Loop through all procedures and sub procedures:
         set ProcNames [lsort -dictionary [concat [list $ProcName] [info procs "$ProcName *"]]]
         foreach ProcName $ProcNames {
            # Skip the (sub) procedure if it has not been explicitly declared. This may be the 

            # case for procedures that are not implemented themselves but which have sub procedures:
            if {![info exists ProcDef($ProcName,VarList)]} continue
            set PureProcName [PureProcName]

            # Add to the help text first the procedure name, and then in the following lines its
            # arguments:
            ProcedureHelp_Append "      $PureProcName"
            if {$ProcDef($ProcName,-named_arguments_first)} {
               set ParClasses {Named Unnamed}
            } else {
               set ParClasses {Unnamed Named}
            }
            foreach ParClass $ParClasses {
               foreach Var $ProcDef($ProcName,${ParClass}VarList) {
                  # Section comment: Create a clean separation of the arguments:
                  if {[info exists ProcDef($ProcName,Arg,$Var,SectionComment)]} {
                     ProcedureHelp_Append "         --- $ProcDef($ProcName,Arg,$Var,SectionComment) ---"
                  }

                  # Argument declaration - put optional arguments into brackets, show the name

                  # of named arguments, add existing descriptions as well as range, type, choice
                  # definitions:
                  set HelpLine "            "
                  if {$ProcDef($ProcName,Arg,$Var,-optional)} {
                     append HelpLine "\["
                  }
                  if {$ProcDef($ProcName,Arg,$Var,IsNamed)} {
                     append HelpLine "-$Var "
                  }
                  if {$ProcDef($ProcName,Arg,$Var,-type)!="none"} {
                     append HelpLine "<$Var>"
                  }
                  if {$ProcDef($ProcName,Arg,$Var,-optional)} {
                     append HelpLine "\]"
                  }
                  ProcedureHelp_Append $HelpLine

................................................................................
                  if {[info exists ProcDef($ProcName,Arg,$Var,-description)]} {
                     append HelpLine "$ProcDef($ProcName,Arg,$Var,-description), "
                  }
                  if {[lsearch -exact {"" "none"} $ProcDef($ProcName,Arg,$Var,-type)]<0} {
                     append HelpLine "type: $ProcDef($ProcName,Arg,$Var,-type), "
                  }
                  if {[info exists ProcDef($ProcName,Arg,$Var,-default)]} {
                     if {[lsearch -exact {"" "string"} $ProcDef($ProcName,Arg,$Var,-type)]>=0 || $ProcDef($ProcName,Arg,$Var,-default)==""} {

                        append HelpLine "default: \"$ProcDef($ProcName,Arg,$Var,-default)\", "
                     } else {
                        append HelpLine "default: $ProcDef($ProcName,Arg,$Var,-default), "
                     }
                  }
                  if {$ProcDef($ProcName,Arg,$Var,-multiple)} {
                     append HelpLine "multiple: yes, "
................................................................................
                  if {[info exists ProcDef($ProcName,Arg,$Var,-choices)]} {
                     append HelpLine "choices: \{[GetChoiceHelpText $ProcName $Var]\}, "
                  }
                  # Eliminate the last ", ":
                  ProcedureHelp_Append [string range $HelpLine 0 end-2]
               }
            }
            # Remember if descriptions and/or examples are provided for the procedure:

            if {[info exists ProcDef($ProcName,-description)]} {
               incr NbrDescriptions
            }
            if {[info exists ProcDef($ProcName,-example)]} {
               incr NbrExamples
            }
         }
................................................................................
                  } else {
                     ProcedureHelp_Append "      $ProcDef($ProcName,-example)"
                  }
               }
            }
         }
      }
      # The created help text is by default printed to stdout.  The text will be returned
      # as result when 'ReturnHelp' is set to 1:

      if {$ReturnHelp} {
         return $HelpText
      } else {
         puts $HelpText
      }
   }

##########################################################################
#                        argument_dialogbox                            #
##########################################################################

   ######## Argument_dialogbox configuration ########
   
   # Application specific entry widget procedures can use this array variable to store their own 
   # data, using as index the widget path provided to the procedure, e.g. 
   # argument_dialogbox($W,<sub_index>):
   array set argument_dialogbox {}
   
   # Special elements of this array variable can be specified for testing purposes:

   #
   # Set to following variable to "ok" to simulate an acknowledge of the dialog box and to 
   # "cancel" to simulate an activation of the Cancel button:

   set argument_dialogbox(test,status) ""

   # The following variable can contain a script that is executed for test purposes, before

   # the argument dialog box waits on user interactions. The script is executed in the context
   # of the argument dialog box. Entire user interaction actions can be emulated together 
   # with the previous variable.
   set argument_dialogbox(test,script) {}
   
   # The array variable 'last_parameters' is only used by an argument dialog box when its context 

   # has been specified via the -context attribute. The argument dialog box position and size as 
   # well as its entered data are stored inside this variable when the data are acknowledged and 

   # the form is closed. This allows the form to restore its previous state once it is called 
   # another time.
   array set last_parameters {}
   

   ######## Argument_dialogbox help text ########

   set ArgumentDialogboxHelp {
      argument_dialogbox \
         [-title <DialogBoxTitle>]
         [-window <DialogBoxWindow>]
................................................................................
         [-validatecommand_error_text <Script>]
         <ArgumentDefinition>|<FrameDefinition>|<Comment>
         [<ArgumentDefinition>|<FrameDefinition>|<Separation>|<Comment>]
         [<ArgumentDefinition>|<FrameDefinition>|<Separation>|<Comment>]
         ...

      <FrameDefinition> = -frame <FrameLabel>
      
      <Separation> = -sep {}
      
      <Comment> = -comment {-text <text>}

      <ArgumentDefinition> =
         <ArgumentWidgetType>
         {
            [-variable <variable>]
            [-label <LabelName>]
................................................................................
            [-validatecommand_error_text <Script>]
            [-validatecommand2 <Script>]
            [-validatecommand2_error_text <Script>]
            [<WidgetTypeParameter1> <WidgetTypeParameterValue1>]
            [<WidgetTypeParameter2> <WidgetTypeParameterValue2>]
            ...
         }
      
      <ParameterWidgetType> = <StandardParameterWidgetType>|<ApplicationSpecificParameterWidgetType>

      <StandardParameterWidgetType> = {
         -entry
         -checkbox -radiobox -checkbutton
         -listbox -disjointlistbox -combobox
         -file -existingfile -directory -existingdirectory
................................................................................

   # Eliminate leading tabs in the help text and replace eventual tabs through spaces
   regsub -all -line {^\t\t} $ArgumentDialogboxHelp "" ArgumentDialogboxHelp
   regsub -all -line {\t} $ArgumentDialogboxHelp "   " ArgumentDialogboxHelp

   ######## argument_dialogbox ########

   # The argument dialog box allows a very easy generation of complex dialog boxes that can be 
   # used for tool configuration purposes or to control actions. This command is only available
   # if Tk has been loaded.
   # The argument dialog box accepts only named arguments, e.g. all arguments have to be defined 

   # as argument pairs (-<ArgumentName> <ArgumentValue>). There are some view arguments like -title,

   # -windows and -context that effect the argument dialog box general attitude and embedding. The
   # remaining argument block objective is the definition of variables. Except the two arguments 
   # -frame and -sep that are used to structure graphically the form, all other arguments have to

   # be assigned either to a local or global variable. The argument dialog box will create in the
   # procedure from which it has been called a local variable, unless the variable has not been 
   # defined explicitly as global variable, or as part of a certain namespace.

   # The argument dialog box requires for each variable that has to be controlled a separate 
   # parameter pair. The first element is indicating the entry form that will be used to control 

   # the variable, the second element provides information concerning the variable that has to be
   # defined and about its validation as well as parameters for the entry form. TEPAM provides
   # already a lot of available entry forms, but other application specific forms can easily been
   # added if necessary.
   # The following lines show an example of the way how the argument dialog box is used:

   #
   #   argument_dialogbox \
   #      -title "System configuration" \
   #      -window .dialog_box \
   #      -context test_1 \
   #      \
   #      -frame {-label "File definitions"} \
................................................................................
   #      -frame {-label "Others"} \
   #         -color {-label "Background color" -variable MyColor} \

   proc argument_dialogbox {args} {
      variable argument_dialogbox
      variable ArgumentDialogboxHelp
      variable last_parameters
      
      # Generate an error if Tk hasn't been loaded
      if {[catch {package present Tk}]} {
         return -code error "argument_dialogbox requires Tk!"
      }
      
      # Call an initialization command that generates eventual required images:
      GuiEnvironmentInit

      #### Basic parameter check ####

         # Use the first element of args as args list if args contains only one element:

         if {[llength $args]==1} {
            set args [lindex $args 0]
         }
         # Check if arguments are provided and if the number of arguments is even:

         if {[llength $args]<1} {
            return -code error "argument_dialogbox: no argument is provided"
         }
         if {[llength $args]%2!=0 && $args!="-help"} {
            return -code error "argument_dialogbox: arguments have to be provided in key/value pairs"
         }

      #### Global parameter evaluation and top-level window creation ####

         # The following default widget path can be changed with the -window argument:

         set Wtop .dialog
         
         # Initialize the global parameters
         # YScroll=auto: Scroll is enabled in function of the windows and screen size

         array set ProcOption {
            -validatecommand {} -validatecommand2 {}
            -validatecommand_error_text {} -validatecommand2_error_text {}
            -parent .
            -title "Dialog"
            -yscroll "auto"
         }

         # Read the global parameters by looping through all arguments to select the relevant 
         # ones:
         foreach {ArgName ArgValue} $args {
            switch -- $ArgName {
               -help {puts $ArgumentDialogboxHelp; return}
               -window {set Wtop $ArgValue}
               -parent -
               -context -
               -title -
................................................................................
               -validatecommand_error_text -
               -validatecommand2_error_text {
                  lappend ProcOption($ArgName) $ArgValue
               }
            }
         }

         # Create the dialog box top-level window. Hide it until the windows has been entirely 
         # deployed:
         catch {destroy $Wtop}
         toplevel $Wtop
         wm withdraw $Wtop
         wm title $Wtop $ProcOption(-title)
         wm transient $Wtop $ProcOption(-parent)

         grid [frame $Wtop.sf] -row 0 -column 0 -sticky news
         grid columnconfigure $Wtop 0 -weight 1
         grid rowconfigure $Wtop 0 -weight 1
         frame $Wtop.sf.f
         
         # Delete eventually variables defined by a previous call of the argument dialog box:

         catch {array unset argument_dialogbox $Wtop,*}
         catch {array unset argument_dialogbox $Wtop.*}

      #### Argument dependent dialog box generation ####

         # Loop through all arguments and build the dialog box:
         set ArgNbr -1
         set Framed 0
         set W $Wtop.sf.f
         foreach {ArgName ArgValue} $args {
            incr ArgNbr
            
            # Check that the argument is a named argument:
            if {[string index $ArgName 0]!="-"} {
               return -code error "Argument $ArgName not known"
            }

            # Skip the global parameters that have already been processed

            if {[lsearch -exact {-window -parent -context -title -help -yscroll
                                 -validatecommand -validatecommand2
                                 -validatecommand_error_text -validatecommand2_error_text} $ArgName]>=0} continue

            
            # Define the widget path for the new argument:
            set WChild($ArgNbr) $W.child_$ArgNbr
            
            # An argument option array will be created, based on the argument value list:

            if {$ArgName!="-sep"} {
               catch  {unset Option}
               array set Option {-label "" -optional 0}
               if {[llength $ArgValue]%2!=0} {

                  return -code error "argument_dialogbox, argument $ArgName: Attribute definition list has to contain an even number of elements"
               }
               array set Option $ArgValue
            }
            
            # The leading '-' of the argument name will not be used anymore in the remaining code:

            set ElementType [string range $ArgName 1 end]
            switch -- $ElementType {
               frame {
                  # Handle frames - close an eventual already open frame first:
                  if {$Framed} {
                     set W [winfo parent [winfo parent $W]]
                     set WChild($ArgNbr) $W.child_$ArgNbr
                  }
                  set Framed 0
                  
                  # Create only a new frame when the provided argument list is not empty:

                  if {$ArgValue!=""} {
                     # Create a labeled frame (for Tk 8.3 that doesn't contain a label frame)
                     set FontSize 10
                     pack [frame $WChild($ArgNbr) -bd 0] \
                        -pady [expr $FontSize/2] -padx 2 -fill both -expand no
                     pack [frame $WChild($ArgNbr).f -bd 2 -relief groove] \
                        -pady [expr $FontSize/2] -fill both -expand no
                     place [label $WChild($ArgNbr).label -text $Option(-label)] \
                        -x $FontSize -y [expr $FontSize/2] -anchor w
                     pack [canvas $WChild($ArgNbr).f.space -height [expr $FontSize/4] -width 10] \
                        -pady 0
                     set W $WChild($ArgNbr).f
                     set Framed 1
                  }
               }

               sep {
                  # A separator is nothing else than a frame widget that has 'no height' and a 
                  # relief structure:
                  pack [frame $WChild($ArgNbr) -height 2 -borderwidth 1 -relief sunken] \
                     -fill x -expand no -pady 4
               }

               comment {
                  # A simple label widget is used for comments:
                  pack [label $WChild($ArgNbr) -text $Option(-text) -fg blue -justify left] \
                     -anchor w -expand no -pady 2
               }
               
               default {
                  # All other arguments, e.g. the real entries to define the variables, are 

                  # handled by procedures that provides sub commands for the different usages:
                  #   ad_form(<EntryType>) create - creates the entry widget
                  #   ad_form(<EntryType>) set_choice - set the choice constraints
                  #   ad_form(<EntryType>) set - set the default value
                  #   ad_form(<EntryType>) get - read the defined value

                  # Create a text in front of the entry widget if the -text attribute is defined:

                  if {[info exists Option(-text)]} {
                     pack [label $WChild($ArgNbr)_txt -text $Option(-text) -fg blue \
                        -justify left] -anchor w -expand no -pady 2
                  }

                  # Create for the entry a frame and place the label together with a sub frame
                  # into it:
                  pack [frame $WChild($ArgNbr)] -fill x -expand yes
                  pack [label $WChild($ArgNbr).label -text $Option(-label)] -pady 4 -side left
                  pack [frame $WChild($ArgNbr).f] -fill x -expand yes -side left
                              
                  # Delete eventual existing array members related to the new entry:
                  array unset argument_dialogbox $WChild($ArgNbr),*
                  
                  # Create the variable entry form:
                  ad_form($ElementType) $WChild($ArgNbr).f create
                  
                  # Attribute if existing the choice list. This list can either be provided via 

                  # the -choicevariable or via -choices:
                  if {[info exists Option(-choicevariable)] && \
                      [uplevel 1 "info exists \"$Option(-choicevariable)\""]} {
                     ad_form($ElementType) $WChild($ArgNbr).f set_choice \
                           [uplevel 1 "set \"$Option(-choicevariable)\""]
                  } elseif {[info exists Option(-choices)]} {
                     ad_form($ElementType) $WChild($ArgNbr).f set_choice $Option(-choices)
                  }
                  
                  # Apply the default value. If the variable exists already, use the variable value

                  # as default value. Otherwise, check if the last_parameter array provides the
                  # value from a previous usage. And finally, check if a default value is provided
                  # via the -default option:
                  if {[info exists Option(-variable)] && \
                      [uplevel 1 "info exists \"$Option(-variable)\""]} {
                     ad_form($ElementType) $WChild($ArgNbr).f set \
                           [uplevel 1 "set \"$Option(-variable)\""]
                  } elseif {[info exists Option(-variable)] && [info exists ProcOption(-context)] && \
                            [info exists last_parameters($ProcOption(-context),$Option(-variable))]} {
                     ad_form($ElementType) $WChild($ArgNbr).f set \
                              $last_parameters($ProcOption(-context),$Option(-variable))
                  } elseif {[info exists Option(-default)]} {
                     ad_form($ElementType) $WChild($ArgNbr).f set $Option(-default)
                  }
                  
                  # Check if the 'Validate' command is defined for the provided variable type:

                  if {[info exists Option(-type)] && [catch {Validate($Option(-type)) ""}]} {

                     return -code error "Argument_dialogbox: Argument type '$Option(-default)' not known"
                  }
               }
            }
         }

      #### Dialog box finalization ####

         # Add the OK and cancel buttons, restore eventually saved geometry data and deiconify finally 
         # the form:
         grid [frame $Wtop.buttons] -row 1 -column 0 -columnspan 2 -sticky ew
         button $Wtop.buttons.ok -text OK -command "set ::tepam::argument_dialogbox($Wtop,status) ok"
         button $Wtop.buttons.cancel -text Cancel -command "set ::tepam::argument_dialogbox($Wtop,status) cancel"
         pack $Wtop.buttons.ok $Wtop.buttons.cancel -side left -fill x -expand yes

         update
         if {$ProcOption(-yscroll)==1 || ($ProcOption(-yscroll)=="auto" && 
                [winfo reqheight $Wtop.sf.f]+[winfo reqheight $Wtop]>[winfo screenheight $Wtop]*2/3)} {
            place $Wtop.sf.f -x 0 -y 0 -relwidth 1; # -relheight 1
            grid [scrollbar $Wtop.scale -orient v -command "tepam::argument_dialogbox_scroll $Wtop"] -row 0 -column 1 -sticky ns

            wm geometry $Wtop [winfo reqwidth $Wtop.sf.f]x[expr [winfo screenheight $Wtop.sf.f]*2/3]
            update
            tepam::argument_dialogbox_scroll $Wtop init

            # Add the bindings
            bind $Wtop.sf <Configure> "tepam::argument_dialogbox_scroll $Wtop config %W %w %h"
            bind $Wtop <MouseWheel> "if {%D>0} {tepam::argument_dialogbox_scroll $Wtop scroll -1 units} elseif {%D<0} {tepam::argument_dialogbox_scroll $Wtop scroll 1 units}"
            bind $Wtop <Button-4> "tepam::argument_dialogbox_scroll $Wtop scroll -1 units"
            bind $Wtop <Button-5> "tepam::argument_dialogbox_scroll $Wtop scroll 1 units"
................................................................................
         if {[info exists ProcOption(-context)] && [info exists last_parameters($ProcOption(-context),-geometry)]} {
            ConfigureWindowsGeometry $Wtop $last_parameters($ProcOption(-context),-geometry)
         }

         wm protocol $Wtop WM_DELETE_WINDOW "set ::tepam::argument_dialogbox($Wtop,status) cancel"

         wm deiconify $Wtop



      #### Wait until the dialog box entries are acknowledged (OK button) or discarded #
      
         # Execute a script if required (only for testing purposes)
         if {$argument_dialogbox(test,script)!={}} {
            eval $argument_dialogbox(test,script)
         }
      
         # Stay in a loop until all the provided values have been validated:
         while {1} {
            # Wait until the OK or cancel button is pressed:
            set argument_dialogbox($Wtop,status) ""
            if {$argument_dialogbox(test,status)==""} {
               vwait ::tepam::argument_dialogbox($Wtop,status)
               set status $argument_dialogbox($Wtop,status)
            } else { # Emulate the button activation for test purposes
               set status $argument_dialogbox(test,status)
            }

            # Cancel has been pressed - exit the wait loop:
            if {$status=="cancel"} break

            # Read all the provided values, validate them, and assign them the corresponding 
            # variables:
            set ErrorMessage ""
            set ArgNbr -1
            foreach {ArgName ArgValue} $args {
               incr ArgNbr
               
               # Extract the element type (eliminate the leading '-') and the parameters to the
               # Option array:
               set ElementType [string range $ArgName 1 end]
               if {[llength $ArgValue]<2 || [llength $ArgValue]%2!=0} continue
               catch  {unset Option}
               array set Option {-label "" -optional 0}
               array set Option $ArgValue
                # No variable is assigned to the entry, so skip this parameter:
               if {![info exists Option(-variable)]} continue
   
               # Read the result, check it and assign the result variable
               set Value [ad_form($ElementType) $WChild($ArgNbr).f get]
   
               # Validate the provided data:
               if {$Value!="" || $Option(-optional)==0} {
                  if {[info exists Option(-type)] && ![Validate($Option(-type)) $Value]} {

                     append ErrorMessage "$Option(-variable): Required type is $Option(-type)\n"
                  }
                  # Apply the validate command if existing:
                  if {[info exists Option(-validatecommand)]} {
                     regsub {%P} $Option(-validatecommand) $Value ValidateCommand
                     if {![uplevel $ValidateCommand]} {
                        if {[info exists Option(-validatecommand_error_text)]} {

                           append ErrorMessage "$Option(-validatecommand_error_text)\n"
                        } else {

                           append ErrorMessage "$Option(-variable): The value '$Value' is not valid\n"
                        }
                     }
                  }
                  # Check against a provided range:
                  if {[info exists Option(-range)]} {
                     if {$Value<[lindex $Option(-range) 0] || \
                         $Value>[lindex $Option(-range) 1]} {
                        append ErrorMessage "$Option(-variable): The value has to be between [lindex $Option(-range) 0] and [lindex $Option(-range) 1]\n"
                     }
                  }
                  # Check that the variable value is a member of a provided choice list. Some 

                  # flexibility is required for this check, since the specified value may be a list 

                  # of multiple elements that are matching the choice list.
                  if {[info exists Option(-choices)]} {
                     set ChoiceError 0
                     foreach v $Value {
                        if {[lsearch -exact $Option(-choices) $v]<0} {
                        incr ChoiceError
                        }
                     }
                     if {$ChoiceError && [lsearch -exact $Option(-choices) $Value]<0} {

                        append ErrorMessage "$Option(-variable): The value(s) has(have) to be one of the following elements: $Option(-choices)\n"
                     }
                  }
               }
               if {[info exists ProcOption(-context)]} {
                  set last_parameters($ProcOption(-context),$Option(-variable)) $Value
               }
            }

            if {$ErrorMessage==""} {
               #### Assign the values to the variables ####
               set ArgNbr -1
               foreach {ArgName ArgValue} $args {
                  incr ArgNbr
                  # Extract the element type (eliminate the leading '-') and the parameters to the
                  # Option array:
                  set ElementType [string range $ArgName 1 end]
                  if {[llength $ArgValue]<2 || [llength $ArgValue]%2!=0} continue
                  catch  {unset Option}
                  array set Option {-label "" -optional 0}
                  array set Option $ArgValue
                   # No variable is assigned to the entry, so skip this parameter:

                  if {![info exists Option(-variable)]} continue
   
                  # Read the result, check it and assign the result variable
                  set Value [ad_form($ElementType) $WChild($ArgNbr).f get]
   
                  # Define the variable in the context of the calling procedure:
                  if {$Value!="" || $Option(-optional)==0} {
                     uplevel 1 "set \"$Option(-variable)\" \{$Value\}"
                  }
               }

               #### Perform the custom argument validations ####
               
               foreach {VCommandO VCommandErrTxtO VLevel} {
                  -validatecommand -validatecommand_error_text 1
                  -validatecommand2 -validatecommand2_error_text 2
               } {
                  foreach ValidateCommand $ProcOption($VCommandO) ValidateCommandErrTxt $ProcOption($VCommandErrTxtO) {
                     if {![uplevel $VLevel $ValidateCommand]} {
                        if {$ValidateCommandErrTxt!=""} {
                           append ErrorMessage "$ValidateCommandErrTxt\n"
                        } else {
                           append ErrorMessage "Validation constraint '$ArgValue' is not satisfied\n"
                        }
                     }
                  }
               }
            }

            # Exit the loop if everything could be validated
            if {$ErrorMessage==""} break

            # Generate otherwise an error message box
            if {$argument_dialogbox(test,status)==""} {
               tk_messageBox -icon error -title Error -type ok -parent $Wtop \
                             -message "The entries could not be successfully validated:\n\n$ErrorMessage\nPlease correct the related entries."
               raise $Wtop
            } else { # Return the error message as error for test purposes
               return -code error "The entries could not be successfully validated:\n\n$ErrorMessage\nPlease correct the related entries."
            }
         }
         
         #### Save the dialog box geometry and destroy the form ####

         if {[info exists ProcOption(-context)]} {

            set last_parameters($ProcOption(-context),-geometry) [wm geometry $Wtop]
         }

         destroy $Wtop
         array unset argument_dialogbox $Wtop,*
         return $status
   }

   # The procedure 'argument_dialogbox_scroll' is used by the argument dialogbox y-scrollbar to

   # execute the scroll commands. It implements the Tk typical scroll commands like 'moveto', 
   # 'scroll x pages/units'. In addition to this it implements also an initialization (used to
   # initialize the scrolled frame) and a configuragion command that can be executed when a 
   # configuration event happens.
   proc argument_dialogbox_scroll {Wtop Command args} {
      set FrameHeight [winfo reqheight $Wtop.sf.f]
      set VisibleHeight [expr 1.0*[winfo height $Wtop.sf]/$FrameHeight]
      set ActualPositionY [lindex [$Wtop.scale get] 0]

      switch -- $Command {
         init {
            set ::tepam::argument_dialogbox($Wtop,wsize) ""
         }
         config {
            if {[lindex $args 0]!="$Wtop.sf" || $args==$::tepam::argument_dialogbox($Wtop,wsize)} return
            set ::tepam::argument_dialogbox($Wtop,wsize) $args
            argument_dialogbox_scroll $Wtop moveto 0
         }
         moveto {
            # Get the desired scroll position, and keep it within the valid scroll range

            set NewPositionY [lindex $args 0]
            if {$NewPositionY<0} {set NewPositionY 0}
            if {$NewPositionY>1.0-$VisibleHeight} {set NewPositionY [expr 1.0-$VisibleHeight]}

            # Adjust the scrollable frame location
            place configure $Wtop.sf.f -y [expr -1.0*$NewPositionY*$FrameHeight]

            # Adjust the scrollbar status
            $Wtop.scale set $NewPositionY [expr $NewPositionY+$VisibleHeight]
         }
         scroll {
            set StepH [expr 30.0/$FrameHeight]; # This defines the scroll unit

            switch -- $args {
               "-1 pages" {
                  argument_dialogbox_scroll $Wtop moveto [expr $ActualPositionY-$VisibleHeight]
               }
               "1 pages" {
                  argument_dialogbox_scroll $Wtop moveto [expr $ActualPositionY+$VisibleHeight]
               }
               "-1 units" {
                  argument_dialogbox_scroll $Wtop moveto [expr $ActualPositionY-$StepH]
               }
               "1 units" {
                  argument_dialogbox_scroll $Wtop moveto [expr $ActualPositionY+$StepH]
               }
            }
         }
      }
   }

   # Create the necessary resources when the argument dialog box is called the first time:

   proc GuiEnvironmentInit {} {
      if {[lsearch [image names] Tepam_SmallFlashDown]>=0} return
      image create bitmap Tepam_SmallFlashDown -data {#define down_width 8
         #define down_height 8
         static unsigned char down_bits[] = {
            0x00 0x00 0xff 0x7e 0x3c 0x18 0x00 0x00 }; }
   }

   # The following procedure defines the geometry (WxH+-X+-Y) of a window. The geometry is provided as

   # second parameter. The position (X/Y) are verified and corrected if necessary to make the window
   # entirly visible on the screen.
   # This position correction is particularly interesting if an application runs within the same user 

   # environment, but with different screen configurations.
   proc ConfigureWindowsGeometry {W Geometry} {
      set Width 200
      set Height 150
      regexp {^(\d+)x(\d+)} $Geometry {} Width Height

      set X ""
      set Y ""
      if {[regexp {([+-]+\d+)([+-]+\d+)$} $Geometry {} X Y]} {
         if {$X<0} {set X +0}
         # if {$X>[winfo screenwidth .]-[winfo reqwidth $W]} {set X +[expr [winfo screenwidth .]-[winfo reqwidth $W]]}
         if {$X>[winfo screenwidth .]-$Width} {set X +[expr [winfo screenwidth .]-$Width]}

         if {$Y<0} {set Y +0}
         # if {$Y>[winfo screenheight .]-[winfo reqheight $W]} {set Y +[expr [winfo screenheight .]-[winfo reqheight $W]]}
         if {$Y>[winfo screenheight .]-$Height} {set Y +[expr [winfo screenheight .]-$Height]}
      }
      

      wm geometry $W ${Width}x${Height}${X}${Y}



   }

   ######## Standard entry forms for the argument_dialogbox ########

   # A dedicated procedure that handles the geometrical aspects of the argument dialog box is 

   # required for each argument type. The prototype header of such a procedure is:
   #
   #    proc ad_form(<EntryType>) {W Command {Par ""}} <Body>
   #
   # The argument 'W' provides the path into which the entry has to be embedded.
   # The procedures have to provide several sub command. The optional argument 'Par' is only used 

   # for the 'set' and 'set_choice' sub commands:
   #
   #    ad_form(<EntryType>) <W> create
   #       This sub command has to creates the form for the given entry type.
   #
   #    ad_form(<EntryType>) <W> set_choice <ChoiceList>
   #       This sub command has to define the available selections (choice lists).
   #
................................................................................
   #          "create" {<Form creation script>}
   #          "set" {<Default value setting script>}
   #          "set_choice" {<Choice list definition script>}
   #          "get" {return [<Value evaluation script>]}
   #       }
   #    }
   #
   # The parameter definition list is mapped to the Option array variable when the ad_form

   # procedures are called. These procedures can access these parameters via the Option variable
   # of the calling procedure using the upvar statement.
   # The provided frame into which each ad_form procedure can deploy the argument definition entry

   # is by default not expandable. To make them expandable, for example for list boxes, the
   # procedure ad_form(make_expandable) has to be called providing it with the entry path:


   proc ad_form(make_expandable) {W} {
      upvar 2 Framed Framed  FontSize FontSize
      # Override the not expanded parent frames:
      pack $W -fill both -expand yes
      pack [winfo parent $W] -fill both -expand yes
      if {$Framed} {
         # Make the parent frames expandable for that the listbox can also expand

         pack [winfo parent [winfo parent [winfo parent $W]]] \
            -pady [expr $FontSize/2] -fill both -expand yes
         pack [winfo parent [winfo parent $W]] \
            -pady [expr $FontSize/2] -fill both -expand yes
      }
   }

   # Implement now all entries:

   #### Simple text entry ####

   proc ad_form(entry) {W Command {Par ""}} {
      switch $Command {
         "create" {
            pack [entry $W.entry] -fill x -expand yes -pady 4 -side left }
         "set" {
            $W.entry delete 0 end; # Clear the existing selection in case the 'set' command is called multiple times


            $W.entry insert 0 $Par
         }
         "get" {
            return [$W.entry get]
         }
      }
   }
................................................................................
   proc ad_form(text) {W Command {Par ""}} {
      # puts "ad_form(text) $W $Command $Par"
      upvar Option Option
      switch $Command {
         "create" {
            ad_form(make_expandable) $W
            grid [text $W.text -yscrollcommand "$W.yscrollbar set"] -column 0 -row 0 -pady 2 -sticky news
            grid [scrollbar $W.yscrollbar -command "$W.text yview"] -column 1 -row 0 -pady 2 -sticky ns

            # Add a horizontal scroll bar if wrapping is disabled
            if {[info exists Option(-wrap)] && $Option(-wrap)=="none"} {
               grid [scrollbar $W.xscrollbar -command "$W.text xview" -orient horizontal] -column 0 -row 1 -sticky ew
               $W.text config -xscrollcommand "$W.xscrollbar set"
            }
            grid columnconfigure $W 0 -weight 1
            grid rowconfigure $W 0 -weight 1
            
            # Apply the text widget parameters
            $W.text config -wrap word -height 4; # Default parameters
            foreach Par {-height -wrap} {
               if {[info exists Option($Par)]} {
                  $W.text config $Par $Option($Par)
               }
            }
................................................................................
            return [$W.text get 0.0 "end - 1 chars"]
         }
      }
   }

   #### Color entry ####

   # Select_color sets the text and color of the color entry to a new color: 
   proc select_color {W NewColor} {
      if {$NewColor!=""} {
         $W.entry delete 0 end
         $W.entry insert 0 $NewColor
      }
      $W.entry config -background gray80
      catch {$W.entry config -background [$W.entry get]}
   }

................................................................................
         set Option(-type) color
      }
      set Title ""
      catch {set Title $Option(-label)}
      switch $Command {
         "create" {
            pack [entry $W.entry] -fill x -expand yes -pady 4 -side left
            pack [button $W.button -text Choose -command "::tepam::select_color $W \[tk_chooseColor -parent \{$W\} -title \{$Title\}\]"] -pady 4 -side left

            bind $W.entry <Key-Return> "tepam::select_color $W {}"
            bind $W.entry <Leave> "tepam::select_color $W {}"
         }
         "set" {
            select_color $W $Par
         }
         "get" {
................................................................................
      }
   }

   #### File and directory entries ####

   # Select_file sets the file or directory entry to a new file name:
   proc select_file {W NewFile} {
      if {$NewFile==""} return
      $W.entry delete 0 end
      $W.entry insert 0 $NewFile
   }

   # Ad_form(directory_or_file) is a generic implementation of a file and directory selection
   # form. It will be used for the different file and directory types:

   proc ad_form(directory_or_file) {W Type Command {Par ""}} {
      upvar 2 Option Option
      if {![info exists Option(-type)]} {
         set Option(-type) $Type
      }
      set Title ""
      catch {set Title $Option(-label)}
................................................................................
            set InitialFile "\[$W.entry get\]";
            if {[info exists Option(-initialfile)]} {
               set InitialFile $Option(-initialfile)
               set ActiveDir [file dirname $Option(-initialfile)]
            }

            pack [entry $W.entry] -fill x -expand yes -pady 4 -side left
            if {$Type=="existingdirectory"} {
               pack [button $W.button -text Browse -command "::tepam::select_file $W \[tk_chooseDirectory -parent $W                         -initialdir \"$ActiveDir\"                               -title \{$Title\}\]"] -pady 4 -side left
            } elseif {$Type=="directory"} {
               pack [button $W.button -text Browse -command "::tepam::select_file $W \[tk_chooseDirectory -parent $W                         -initialdir \"$ActiveDir\"                               -title \{$Title\}\]"] -pady 4 -side left
            } elseif {$Type=="existingfile"} {
               pack [button $W.button -text Browse -command "::tepam::select_file $W \[tk_getOpenFile   -parent $W -filetypes \{$FileTypes\} -initialdir \"$ActiveDir\" -initialfile \"$InitialFile\" -title \{$Title\}\]"] -pady 4 -side left
            } else { # file

               pack [button $W.button -text Browse -command "::tepam::select_file $W \[tk_getSaveFile  -parent $W -filetypes \{$FileTypes\} -initialdir \"$ActiveDir\" -initialfile \"$InitialFile\" -title \{$Title\}\]"] -pady 4 -side left
            }
         }
         "set" {
            $W.entry delete 0 end; # Clear the existing selection in case the 'set' command is called multiple times
            $W.entry insert 0 $Par
         }
         "get" {
            return [$W.entry get]
         }
      }
   }

   # The generic file and directory selection command 'ad_form(directory_or_file)' are used to

   # implement the 4 file and directory selection forms:

   proc ad_form(directory) {W Command {Par ""}} {
      ad_form(directory_or_file) $W directory $Command $Par
   }

   proc ad_form(existingdirectory) {W Command {Par ""}} {
      ad_form(directory_or_file) $W existingdirectory $Command $Par
................................................................................
   }

   #### Combobox ####

   proc ad_form(combobox) {W Command {Par ""}} {
      switch $Command {
         "create" {
            pack [entry $W.entry -borderwidth 2] -fill x -expand yes -pady 4 -side left
               pack [button $W.button -relief flat -borderwidth 0 -image Tepam_SmallFlashDown -command "tepam::ad_form(combobox) $W open_selection"] -pady 4 -side left

               toplevel $W.selection -border 1 -background black



               wm overrideredirect $W.selection 1




               wm withdraw $W.selection
            pack [listbox $W.selection.listbox -yscrollcommand "$W.selection.scrollbar set" -exportselection 0] -fill both -expand yes -side left
            pack [scrollbar $W.selection.scrollbar -command "$W.selection.listbox yview"] -fill y -side left -expand no
                     
            bind $W.selection.listbox <<ListboxSelect>> "tepam::ad_form(combobox) $W close_selection"
            bind $W.selection <FocusOut> "wm withdraw $W.selection"


         }
         "set" {
            $W.entry delete 0 end; # Clear the existing selection in case the 'set' command is called multiple times
            $W.entry insert 0 $Par
         }
         "get" {
            return [$W.entry get]
................................................................................
         }
         "set_choice" {
            foreach v $Par {
               $W.selection.listbox insert end $v
            }
         }
         "open_selection" {
            ConfigureWindowsGeometry $W.selection [expr [winfo width $W.entry]+[winfo width $W.button]]x100+[winfo rootx $W.entry]+[expr [winfo rooty $W.entry]+[winfo height $W.entry]]

            catch {$W.selection.listbox selection clear 0 end}
            catch {$W.selection.listbox selection set [lsearch -exact [$W.selection.listbox get 0 end] [$W.entry get]]}
            catch {$W.selection.listbox yview [lsearch -exact [$W.selection.listbox get 0 end] [$W.entry get]]}
            
            wm deiconify $W.selection

            focus $W.selection }

         "close_selection" {
            $W.entry delete 0 end
            $W.entry insert 0 [$W.selection.listbox get [$W.selection.listbox curselection]]

            wm withdraw $W.selection }












      }
   }

   #### Listbox ####

   proc ad_form(listbox) {W Command {Par ""}} {
      # puts "ad_form(listbox) $W $Command $Par"
................................................................................
      switch $Command {
         "create" {
            ad_form(make_expandable) $W
            pack [listbox $W.listbox -yscrollcommand "$W.scrollbar set" -exportselection 0] -fill both -expand yes -pady 4 -side left
            if {[info exists Option(-multiple_selection)] && $Option(-multiple_selection)} {
               $W.listbox config -selectmode extended
            }
            pack [scrollbar $W.scrollbar -command "$W.listbox yview"] -fill y -pady 4 -side left -expand no
            if {[info exists Option(-height)]} {
               $W.listbox config -height $Option(-height)
            }
         }
         "set" {
            catch {$W.listbox selection clear 0 end}; # Clear the existing selection in case the 'set' command is called multiple times
            if {[info exists Option(-multiple_selection)] && $Option(-multiple_selection)} {
................................................................................
   #### Disjoint listbox ####

   proc disjointlistbox_move {W Move} {
      switch $Move {
         "add" {
            $W.listbox2 selection clear 0 end
            foreach o [lsort -integer -increasing [$W.listbox1 curselection]] {
               if {[$W.listbox1 itemcget $o -foreground]=="grey"} continue
               $W.listbox2 insert end [$W.listbox1 get $o]
               $W.listbox2 selection set end
               $W.listbox1 itemconfigure $o -foreground grey
            }
            $W.listbox1 selection clear 0 end
         }
         "delete" {
            foreach o [lsort -integer -decreasing [$W.listbox2 curselection]] {
               for {set o1 0} {$o1<[$W.listbox1 index end]} {incr o1} {
                  if {[$W.listbox2 get $o]==[$W.listbox1 get $o1]} {
                     $W.listbox1 itemconfigure $o1 -foreground ""
                  }
               }
               $W.listbox2 delete $o
            }
         }
         "up" {
            foreach o [$W.listbox2 curselection] {
               if {$o==0} continue
               $W.listbox2 insert [expr $o-1] [$W.listbox2 get $o]
               $W.listbox2 delete [expr $o+1]
               $W.listbox2 selection set [expr $o-1]
            }
         }
         "down" {
            foreach o [lsort -integer -decreasing [$W.listbox2 curselection]] {
               if {$o==[$W.listbox2 index end]-1} continue
               $W.listbox2 insert [expr $o+2] [$W.listbox2 get $o]
               $W.listbox2 delete $o
               $W.listbox2 selection set [expr $o+1]
            }
         }
      }
   }

   proc ad_form(disjointlistbox) {W Command {Par ""}} {
      # puts "ad_form(listbox) $W $Command $Par"
................................................................................
         "create" {
            ad_form(make_expandable) $W

            grid [label $W.label1 -text "Available"] -column 1 -row 0 -sticky ew
            grid [label $W.label2 -text "Selected"] -column 3 -row 0 -sticky ew

            grid [listbox $W.listbox1 -yscrollcommand "$W.scrollbar1 set" -exportselection 0 -selectmode extended] -column 1 -row 1 -rowspan 2 -sticky news
            grid [scrollbar $W.scrollbar1 -command "$W.listbox1 yview"] -column 2 -row 1 -rowspan 2 -sticky ns
            grid [listbox $W.listbox2 -yscrollcommand "$W.scrollbar2 set" -exportselection 0 -selectmode extended] -column 3 -row 1 -rowspan 2 -sticky news
            grid [scrollbar $W.scrollbar2 -command "$W.listbox2 yview"] -column 4 -row 1 -rowspan 2 -sticky ns

            grid [button $W.up -text "^" -command "::tepam::disjointlistbox_move $W up"] -column 5 -row 1 -sticky news
            grid [button $W.down -text "v" -command "::tepam::disjointlistbox_move $W down"] -column 5 -row 2 -sticky news

            grid [button $W.add -text ">" -command "::tepam::disjointlistbox_move $W add"] -column 1 -row 3 -columnspan 2 -sticky news
            grid [button $W.remove -text "<" -command "::tepam::disjointlistbox_move $W delete"] -column 3 -row 3 -columnspan 2 -sticky news

            foreach {Col Weight} {0 0  1 1   2 0   3 1   4 0   5 0} {
               grid columnconfigure $W $Col -weight $Weight
             }
            grid rowconfigure $W 1 -weight 1
            grid rowconfigure $W 2 -weight 1
            if {[info exists Option(-height)]} {
................................................................................
               $W.listbox2 config -height $Option(-height)
            }
         }
         "set" {
            # Delete an eventually previous selection (this should not be required by argument_dialogox)
            $W.listbox2 selection set 0 end
            disjointlistbox_move $W delete
            
            foreach o $Par {
               set p [lsearch -exact [$W.listbox1 get 0 end] $o]
               if {$p>=0} { # Delete the selected item from the available items
                  $W.listbox1 selection set $p
                  disjointlistbox_move $W add
               }
            }
................................................................................
            set argument_dialogbox($W,ButtonsW) {}
         }
         "set" {
            # Delete an eventually previous selection
            foreach ChoiceIndex [array names argument_dialogbox $W,values,*] {
               set argument_dialogbox($ChoiceIndex) ""
            }
            # Select the check buttons that correspond to the provided values 
            foreach v $Par {
               foreach BW $argument_dialogbox($W,ButtonsW) {
                  if {$v==[$BW cget -onvalue]} {
                     set [$BW cget -variable] $v
                  }
               }
            }
         }

         "get" { # Provide the selected items in the order of the provided choice list

            set Result {}

            foreach ChoiceIndex [lsort -dictionary [array names argument_dialogbox $W,values,*]] {
               if {$argument_dialogbox($ChoiceIndex)!=""} {
                  lappend Result $argument_dialogbox($ChoiceIndex) }
               }
            return $Result
         }
         "set_choice" {
            set ChoiceNumber 0
            set PackSide left
            if {[info exists Option(-direction)] && $Option(-direction)=="vertical"} {
               set PackSide top
            }
            foreach v $Par {
               set label $v
               catch {set label [lindex $Option(-choicelabels) $ChoiceNumber]}
               pack [checkbutton $W.choice_$ChoiceNumber -text $label -variable ::tepam::argument_dialogbox($W,values,$ChoiceNumber) -onvalue $v -offvalue ""] -side $PackSide -anchor w
               lappend argument_dialogbox($W,ButtonsW) $W.choice_$ChoiceNumber
               incr ChoiceNumber
            }
         }
      }
   }

................................................................................
         "get" {
            return $argument_dialogbox($W,values)
         }
         "set_choice" {
            set argument_dialogbox($W,values) [lindex [lindex $Par 0] 0]
            set ChoiceNumber 0
            set PackSide left
            if {[info exists Option(-direction)] && $Option(-direction)=="vertical"} {
               set PackSide top
            }
            foreach v $Par {
               set label $v
               catch {set label [lindex $Option(-choicelabels) $ChoiceNumber]}
               pack [radiobutton $W.choice_$ChoiceNumber -text $label -variable ::tepam::argument_dialogbox($W,values) -value $v] -side $PackSide -anchor w
               incr ChoiceNumber
            }
         }
      }
   }

   #### Checkbutton ####

   proc ad_form(checkbutton) {W Command {Par ""}} {
      variable argument_dialogbox
      switch $Command {
         "create" {
            pack [checkbutton $W.checkb -variable ::tepam::argument_dialogbox($W,values)] -pady 4 -side left
            set argument_dialogbox($W,values) 0
         }
         "set" {
            set argument_dialogbox($W,values) $Par
         }
         "get" {
            return $argument_dialogbox($W,values)
................................................................................
      regexp {^\.*(\..*)$} $parent.font_selection {} W
      catch {destroy $W}
      toplevel $W
      wm withdraw $W
      wm transient $W $parent
      wm group $W $parent
      wm title $W $title


      pack [label $W.into -text "Please choose a font and its size \nand style, then select OK." -justify left] -expand no -fill x

      pack [frame $W.sels] -expand yes -fill both
      pack [listbox $W.sels.lb_font -yscrollcommand "$W.sels.sb_font set" -exportselection 0 -height 10] -side left -expand yes -fill both
         bind $W.sels.lb_font <<ListboxSelect>> "::tepam::ChooseFont_Update $W"
      pack [scrollbar $W.sels.sb_font -command "$W.sels.lb_font yview"] -side left -expand no -fill both
      pack [listbox $W.sels.lb_size -yscrollcommand "$W.sels.sb_size set" -width 3 -exportselection 0 -height 10] -side left -expand no -fill both
         bind $W.sels.lb_size <<ListboxSelect>> "::tepam::ChooseFont_Update $W"
      pack [scrollbar $W.sels.sb_size -command "$W.sels.lb_size yview"] -side left -expand no -fill both

      set ButtonFont [font actual [[button $W.dummy] cget -font]]
      pack [frame $W.styles] -expand no -fill x
      pack [checkbutton $W.styles.bold -text B -indicatoron off -font "$ButtonFont -weight bold" -variable ::tepam::ChooseFont($W,bold) -command "::tepam::ChooseFont_Update $W"] -side left -expand yes -fill x
      pack [checkbutton $W.styles.italic -text I -indicatoron off -font "$ButtonFont -slant italic" -variable ::tepam::ChooseFont($W,italic) -command "::tepam::ChooseFont_Update $W"] -side left -expand yes -fill x
      pack [checkbutton $W.styles.underline -text U -indicatoron off -font "$ButtonFont -underline 1" -variable ::tepam::ChooseFont($W,underline) -command "::tepam::ChooseFont_Update $W"] -side left -expand yes -fill x
      pack [checkbutton $W.styles.overstrike -text O -indicatoron off -font "$ButtonFont -overstrike 1" -variable ::tepam::ChooseFont($W,overstrike) -command "::tepam::ChooseFont_Update $W"] -side left -expand yes -fill x

      pack [label $W.text -text "Test text 1234"] -expand no -fill x
      
      pack [frame $W.buttons] -expand no -fill x
      pack [button $W.buttons.ok -text OK -command "set ::tepam::ChooseFont($W,status) 0"] -side left -expand yes -fill x
      pack [button $W.buttons.cancel -text Cancel -command "set ::tepam::ChooseFont($W,status) 3"] -side left -expand yes -fill x

      # Create the font size and family lists. Use default lists when no family or sizes
      # are provided.
      if {$font_families=={}} {
         set font_families [font families]
      }
      foreach v $font_families {
         $W.sels.lb_font insert end $v
      }

      if {$font_sizes=={}} {
         set font_sizes {6 7 8 9 10 12 14 16 18 20 24 28 32 36 40}
      }
      foreach v $font_sizes {
         $W.sels.lb_size insert end $v
      }

      # Set the default font selection
      if {![info exists default]} {
         set default [$W.text cget -font]
         # puts "default:$default"
      }
      
      set Index [lsearch -exact $font_families [lindex $default 0]]
      if {$Index<0} {set Index [lsearch -exact $font_families [font actual $default -family]]}
      if {$Index<0} {set Index 0}
      # puts "[font actual $default -family] -> $Index"
      $W.sels.lb_font selection clear 0 end
      $W.sels.lb_font selection set $Index
      $W.sels.lb_font yview $Index
................................................................................
      foreach Style [lrange $default 2 end] {
         if {[info exists ::tepam::ChooseFont($W,$Style)]} {
            set ::tepam::ChooseFont($W,$Style) 1
         }
      }

      wm protocol $W WM_DELETE_WINDOW "set ::tepam::ChooseFont($W,status) 3"
      ConfigureWindowsGeometry $W "+[expr [winfo rootx $parent]+[winfo width $parent]+10]+[expr [winfo rooty $parent]+0]"
      wm deiconify $W

      # Wait until the OK or cancel button is pressed:
      set ::tepam::ChooseFont($W,status) ""






      vwait ::tepam::ChooseFont($W,status)

      
      set SelectedFont [ChooseFont_Get $W]
      destroy $W







      if {$::tepam::ChooseFont($W,status)==0} {return $SelectedFont}
      return ""
   }

   # Select_font sets the text and the font of the font entry to a font color: 
   proc select_font {W NewFont} {
      variable argument_dialogbox
      if {$NewFont!=""} {
         $W.entry delete 0 end
         $W.entry insert 0 $NewFont
      }
      $W.entry config -bg gray80
      catch {
         $W.entry config -font [$W.entry get]
         $W.entry config -bg $argument_dialogbox($W,DefaultEntryColor)
................................................................................
      set Title ""
      catch {set Title $Option(-label)}
      switch $Command {
         "create" {
            # The dedicated attributes -font_families and -font_sizes by this entry widget:
            set FamilyList [font families]
            catch {set FamilyList $Option(-font_families)}
            
            set SizeList {6 7 8 9 10 12 14 16 18 20 24 28 32 36 40}
            catch {set SizeList $Option(-font_sizes)}

            # Create the entry widget
            pack [entry $W.entry] -fill x -expand yes -pady 4 -side left
            pack [button $W.button -text Choose \
               -command "::tepam::select_font $W \[::tepam::ChooseFont -parent \{$W\} -title \{$Title\} -font_families \{$FamilyList\} -font_sizes \{$SizeList\} -default \[$W.entry get\]\]"] -pady 4 -side left

            bind $W.entry <Key-Return> "tepam::select_font $W {}"
            bind $W.entry <Leave> "tepam::select_font $W {}"

            set argument_dialogbox($W,DefaultEntryColor) [$W.entry cget -bg]

            # Use the default font of the entry widget as default font selection if its font 
            # family and font size is part of the selection lists. Use otherwise the first 
            # elements of the family list and the closest size for the default font.
            set DefaultFont [$W.entry cget -font]

            set DefaultFamily [font actual $DefaultFont -family]
            if {[lsearch -exact $FamilyList $DefaultFamily]<0} {
               set DefaultFamily [lindex $FamilyList 0]
            }

            set DefaultSize [font actual $DefaultFont -size]
            if {[lsearch -exact $SizeList $DefaultSize]<0} {
               set SizeList [lsort -real [concat $SizeList $DefaultSize]]
               set Pos [lsearch -exact $SizeList $DefaultSize]
               if {$Pos==0} {
                  set DefaultSize [lindex $SizeList 1]
               } elseif {$Pos==[llength $SizeList]-1} {
                  set DefaultSize [lindex $SizeList end-1]
               } elseif {[lindex $SizeList $Pos]-[lindex $SizeList [expr $Pos-1]] <
                         [lindex $SizeList [expr $Pos+1]]-[lindex $SizeList $Pos] } {
                  set DefaultSize [lindex $SizeList [expr $Pos-1]]
               } else {
                  set DefaultSize [lindex $SizeList [expr $Pos+1]]
               }
            }

            select_font $W [list $DefaultFamily $DefaultSize]
         }
         "set" {
            select_font $W $Par
................................................................................

##########################################################################
# Id: tepam.tcl
# Modifications:
#
# TEPAM version 0.5.1 - 2016/03/05 droll
# * Help generation
#   - Correction of bug a0e091b25d (Misformatted description in auto-generated 
#     help text)
#
# TEPAM version 0.5 - 2013/10/14 droll
# * procedure command
#   - New procedure attributes: -validatecommand_error_text, -validatecommand
#   - Updated argument attribute: -validatecommand (the command is now 
#     executed in the context of the procedure body which allows accessing 
#     argument variables)
#   - New argument attribute: -validatecommand_error_text
#   - Minor bug fix: The TEPAM internal procedure list was incorrect if a 
#     procedure was defined multiple times.
#   - Procedure help generation: Indicate if an argument can be used multiple 
#     times
# * argument_dialogbox
#   - New global attributes: -validatecommand_error_text, -validatecommand
#   - New argument attributes: -validatecommand_error_text, -validatecommand,
#                              -validatecommand_error_text2, -validatecommand2
#
# TEPAM version 0.4.1 - 2013/03/25 droll
# * Correction of bug 3608952: Help text is incorrectly generated if procedures 
#   are part of the non-default namespaces
# * Correction of bug 3608951: Help text shows incorrect argument order if 
#   procedure is defined in the "unnamed arguments first, named arguments later" 
#    calling style.
#
# TEPAM version 0.4.0 - 2012/05/07 20:24:58  droll
# * Add the new text procedure argument type and the text multi line data
#   entry widget.
#
# TEPAM version 0.3.0 - 2012/03/26 20:44:10  droll




|
|
|



|






|










|
|
|
>

|
|
|







|
|
>


|
>










|
|






>
|






|




|







 







|




|
>













|
>
|
|
|



|
|
|

|




|
|
>
|
|
|
>
|
|
|
|
|







|
|
>
|



|
|
|

|









|
|
|







 







|
>
|



|
|
>
|
|

|

|







|
>






|
|



|
>
|
>

|
|
>





|



|
>

|







 







|
>
|
>
>
|




>
|
>












|
>












|
>
|




>
|








>
|

>
|


|
|
>
|
|
|
>


|
|
|

|

|




|






|
>



|
|
>
|







 







|

|
|
|
>
|
>





|


|



|
|
>
|



|
|
|



|






|
|
>
|



|










|
|
|












|
|



|


|
|
>
|




|







|
>
|
|
>


|
>


|

|
|
|







|








|
>



|

|
|









|
|



|
|
>



|



|




|
|
|







|












|
>
|



|
|


|




|
>
|
>
|
|
|
|
|
|
>
|
|

>
|
|
>
|


|
>











|
>
|



|
>


|


|
|



|
|
|









|







|
>
|









>
|

>

|
>






>
|
>
|


|
>

|
>
|




|

|
>
|
>
|

|


|


|
>


|
>

|

|
>

|


|




|






|








|







 







|
>

|










|
|








|





>
|


|



|


|
>




|


|


|
>




|
>


|
>










|
|
|



|
>
|













|
>
|
|
>


|
>
|


|
>









|
|


|
|
>




|
|
>
|


|
|
>



|
|
>

|
|
>
|




|



|
>
|
|




|
>
|




|





|
|
|
|
>
|








|
|
|








|
>
|
|



|
|
|
>
|





|
>
|
<

|


>
|
|
|
|






|

>
|

>
|
>
>
>
|
>
>
>
|
>



|
|
|
|
>

|

|
>
|






|
>
|









|




|
|

|
>
|
>
|

>
|


|
|
>


|
|
|
|







 







|
|



|
|
>

>
|

|


|
|





|
>



>
|

|
|
>




>
|

>
|




|
>



>
|



|
>


>
|








>
|


|
>
|

>
|





|


|









|










|


|




|
|
>
|
|
>
|







 







|
|
|
|






|
>
|
|
>
|
|
>




|


|


|


|


|
|
>
|
|


|


|
>

|
|



|
>
|






|

|
|
|
>
|
>

|
|

|




|
>
|

|







|






|
>
|
|
>
|
|
|





|
|
>
|








|
>
|

|
>
|
|
|
>

|




|
>
|







|
>



|



|
>
|



|
|













|
>
|








|







 







|
>







 







|
>







 







|
|
>












|
|
|
|

|
|
>

|
|
>


|
>
|
|
|

|
|
>
|
|
>
|
<

<







 







|

|







 







|







 







|
|
|
|
>
|
>
|
|
|
>
|
|
|
>
|
|
>
|
|
|
|
|
>







 







|




|





|
>
|


|
>



|





|
>

|

|
>








|
|







 







|
|










|
|
>











|

|




>
|
|
|
>
|


|
|
>
|


|
>
|



|
|
>





|



|
|
>
|
|
<
|
<
<
|
<
<
<
<
|





|
|
|
|







|

|
>
|





|
>





|
|
|
|

|


|


|
|
>
|







|
|
>
|
|
|











|
|
>

>
|







|
|

|
|
|

|
|


|

|
<







 








>
>

|

|


|




|







|

|
|




|
|
|

|





|


|

|

>
|






>
|

>
|










|
>
|
>
|




|



>
|








|




|
|

|



|
>

|


|

|





|






|










|


|







|



>
|
|
>
|




|
>
|
|
|
|


|







|




|
>


|


|


|


|
>


|


|


|


|






|
>

<
<
<
<
<


|
>
|
|
|
>
|



|





|
|


|
|

|
>
|
>
>
>




|
>
|



|
|
>
|







 







|
>
|
|
|
>
|
|
>







|
>

|

|












|
>
>







 







|


|
|




|







 







|

|







 







|
>







 







|




|
|
>







 







|
|
|
|
|
|
|
>
|












|
>
|







 







|
|

|
>
>
>
|
>
>
>
>
|
|
|
|

|
>
>







 







|




<

>
|
>



>
|
>
>
>
>
>
>
>
>
>
>
>
>







 







|







 







|









|








|
|
|
|




|
|

|







 







|

|

|
|

|
|







 







|







 







|


|





>
|
>

>
|
|







|





|







 







|





|












|







 







>



|

|
|

|
|


|






|

|
|



|






|











|







 







|
<



>
>
>
>
>
>

>
|


>
>
>
>
>
>
>
|



|


|







 







|





|
|
>





|
|












|
|
|
|
|
|
|

|







 







|





|
|


|

|







|

|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
...
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
...
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
...
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
...
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
...
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
....
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
....
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
....
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
....
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
....
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
....
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
....
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
....
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
....
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
....
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
....
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
....
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
....
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
....
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
....
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
....
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
....
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
....
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
....
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
....
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
....
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
....
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
....
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
....
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
....
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
....
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
....
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
....
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
##########################################################################
# TEPAM - Tcl's Enhanced Procedure and Argument Manager
##########################################################################
# tepam.tcl - TEPAM main Tcl package
#
# TEPAM offers an alternative way to declare Tcl procedures. It provides
# enhanced argument handling features like automatically generated,
# graphical entry forms and checkers for the procedure arguments.
#
# Copyright (C) 2009/2010/2011 Andreas Drollinger
#
# Id: tepam.tcl
##########################################################################
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
##########################################################################

package require Tcl 8.5

namespace eval tepam {
   # Exports the major commands from this package:
   namespace export procedure argument_dialogbox

##########################################################################
#                            procedure                                   #
##########################################################################

   ######## Procedure configuration ########

   # Set the following variable to 0 (false) prior to the procedure
   # definition, to use first the unnamed arguments and then the named
   # arguments.
   set named_arguments_first 1

   # Setting the following variable to 0 will disable the automatic argument
   # name extension feature.
   set auto_argument_name_completion 1

   # Set the following variable prior to the procedure definition to:
   #   - 0 (false): to disable command logging
   #   - 1 (true): to log all commands anytime
   #   - "interactive": to log only interactively called commands
   set command_log "interactive"

   # Set the following variable to "short" to generate small interactive
   # dialog boxes.
   set interactive_display_format "extended"

   # The following variable defines the maximum line length a created
   # help text can have:
   set help_line_length 80

   ######## Internal variables ########

   if {![info exists ProcedureList]} {
      set ProcedureList {}
   }

   ######## PureProcName ########

   # PureProcName purifies the procedure name given by the ProcName variable
   # of the calling function and returns it. PureProcName is basically:
   # * Eliminating the main namespace indicators
   # * Encapsulating the name into '' if it is a composed name
   proc PureProcName {args} {
      upvar ProcName ProcName
      set Name $ProcName
      regsub {^::} $Name {} Name; # Eliminate the main namespace indicators
      if {[lsearch $args -appo]>=0} {
         # Encapsulate the name into '' if it is a composed name
         set Name "'$Name'"
      }
      return $Name
   }

   ######## Procedure help text ########

   set ProcedureHelp {
      procedure <ProcedureName> <ProcedureAttributes> <ProcedureBody>

      <ProcedureAttributes> = {
         [-category <Category>]
         [-short_description <ShortDescription>]
         [-description <Description>]
         [-return <Return_Type>]
         [-example <Example>]
         [-named_arguments_first 0|1]
         [-command_log 0|1|"interactive"]
         [-auto_argument_name_completion 0|1]
................................................................................
         [-range {<MinValue> <MaxValue>}
         [-multiple]
         [-auxargs <AuxilaryArgumentList>]
         [-auxargs_commands <AuxilaryArgumentCommandList>]
      }

      <ArgumentType> = {
         none double integer alnum alpha ascii control digit graph lower
         print punct space upper wordchar xdigit color font boolean ""
      }
   }

   # Eliminate leading tabs in the help text and replace eventual tabs
   # through spaces
   regsub -all -line {^\t\t} $ProcedureHelp "" ProcedureHelp
   regsub -all -line {\t} $ProcedureHelp "   " ProcedureHelp

   ######## Procedure ########

   # Procedure allows declaring a new procedure in the TEPAM syntax:
   #
   #    procedure my_proc {
   #       -args {message}
   #    } {
   #       puts $message; # Procedure body
   #    }
   #
   # Procedure creates in fact a TCL procedure with a patched procedure
   # body. This body calls at the beginning an argument parser
   # (ProcedureArgumentEvaluation) that is reading and validating
   # the arguments that have been provided to the procedure. The
   # previous lines are for example creating the following TCL procedure:
   #
   #    proc my_proc {args} {
   #       ::tepam::ProcedureArgumentEvaluation;
   #       if {$ProcedureArgumentEvaluationResult ne ""} {
   #          if {$ProcedureArgumentEvaluationResult eq "cancel"} return
   #          return -code error $ProcedureArgumentEvaluationResult
   #       }
   #       if {$SubProcedure ne ""} {return [$SubProcedure]}
   #
   #       puts $message; # Procedure body
   #    }
   #
   # ProcedureArgumentEvaluation uses the TCL procedure args argument to
   # read all the provided arguments. It evaluates first if a sub procedure
   # has to be called. This information and the argument validation result
   # are provided to the calling procedure respectively via the variables
   # SubProcedure and ProcedureArgumentEvaluationResult. In case the result
   # evaluation was not successful, the calling procedure body will simply
   # return. In case the procedure call refers to a sub-procedure, this one
   # will be called. Otherwise, if a valid argument set has been provided
   # to the procedure, and if no sub-procedure has to be called, the original
   # procedure body is executed. Procedure behaves slightly differently in
   # case one or multiple sub-procedures have been declared without declaring
   # the main procedure itself:
   #
   #    procedure {my_func sub_func} {
   #       -args {message}
   #    } {
   #       puts $message; # Procedure body
   #    }
   #
   # Procedure creates in this case for the main procedure a Tcl procedure
   # as well as for the sub-procedure. The main procedure creates an error
   # when it directly called. The sub-procedure is executed within the main
   # procedure context using the uplevel command.
   #
   #    proc my_proc {args} {
   #       ::tepam::ProcedureArgumentEvaluation;
   #       if {$ProcedureArgumentEvaluationResult ne ""} {
   #         if {$ProcedureArgumentEvaluationResult eq "cancel"} return
   #         return -code error $ProcedureArgumentEvaluationResult
   #       }
   #       if {$SubProcedure ne ""} {return [$SubProcedure]}
   #       error "'my_func' requires a subcommand"
   #    }
   #
   #    proc {my_proc sub_func} {args} {
   #       uplevel 1 {
   #          puts $message; # Procedure body
   #       }
   #    }
   #
   # Procedure parses itself the procedure name and attributes and creates
   # the new TCL procedure with the modified body. For each declared
   # argument it calls ProcedureArgDef which handles the argument definition.

   proc procedure {args} {
      variable ProcDef
      variable ProcedureHelp
      variable named_arguments_first
      variable command_log
      variable auto_argument_name_completion
................................................................................

         # Check if help is requested:
         if {[lsearch -exact $args "-help"]>=0} {
            puts $ProcedureHelp
            return
         }

         # Check that the procedure name, argument list and body has
         # been provided:
         if {[llength $args] != 3} {
            return -code error "Missing procedure arguments, correct usage: procedure <ProcedureName>\
                   <ProcedureAttributes> <ProcedureBody>"
         }

         # Evaluate the full qualified procedure name including a leading
         # name space identifier.
         # Evaluate the current namespace in case the procedure is not
         # defined explicitly with a name space:
         regsub -all {\s+} [lindex $args 0] " " ProcName
         if {[string range $ProcName 0 1] ne "::"} {
            set NameSpace [uplevel 1 {namespace current}]
            if {$NameSpace ne "::"} {append NameSpace "::"}
            set ProcName ${NameSpace}${ProcName}
         }

         # Extract the procedure attributes and the procedure body:
         set ProcedureAttributes [lindex $args 1]
         set ProcedureBody [lindex $args 2]

         # Store the procedure name in the procedure list, if it is not
         # already existing:
         if {[lsearch -exact $ProcedureList $ProcName]<0} {
            lappend ProcedureList $ProcName
         }

      #### Initialize the procedure attributes ####

         # Clean the information of an eventual previous procedure
         # definition, and store the actual configured procedure modes:
         catch {array unset ProcDef $ProcName,*}
         set ProcDef($ProcName,-named_arguments_first) $named_arguments_first
         set ProcDef($ProcName,-command_log) $command_log
         set ProcDef($ProcName,-auto_argument_name_completion) \
            $auto_argument_name_completion
         set ProcDef($ProcName,-interactive_display_format) \
            $interactive_display_format

         # The procedure information will be stored in the array variable
         # ProcDef. The following array members are always defined for
         # each declared procedure:
         set ProcDef($ProcName,-validatecommand) {}
         set ProcDef($ProcName,-validatecommand_error_text) {}
         set ProcDef($ProcName,VarList) {}
         set ProcDef($ProcName,NamedVarList) {}
         set ProcDef($ProcName,UnnamedVarList) {}
         #  ProcDef($ProcName,NbrVars)
         #  ProcDef($ProcName,NbrNamedVars)
         #  ProcDef($ProcName,NbrUnnamedVars)

         # The following array members are defined optionally in the
         # argument parsing section:
         #  ProcDef($ProcName,$AttributeName)
         #                    | AttributeName = {-category -return -short_description
         #                    |                  -description -example}
         #
         #  ProcDef($ProcName,Arg,$Var,IsNamed)
         #  ProcDef($ProcName,Arg,$Var,-type)
         #  ProcDef($ProcName,Arg,$Var,-optional)
         #  ProcDef($ProcName,Arg,$Var,-validatecommand)
         #  ProcDef($ProcName,Arg,$Var,-validatecommand_error_text)
................................................................................
         #                    | Contains the choice label list: {<ChoiceLabel1> ... <ChoiceLabelN>}
         #  ProcDef($ProcName,Arg,$Var,-range)
         #  ProcDef($ProcName,Arg,$Var,SectionComment)
         #  ProcDef($ProcName,Arg,$Var,Comment)

      #### Parse all procedure attributes ####

         # Variable that will be set to '1' if an unnamed argument is optional.
         set UnnamedHasToBeOptional 0
         # Variable that will be set to '1' if an unnamed argument has the
         # -multiple option
         set UnnamedWasMultiple 0

         # Loop through the argument definition list:
         foreach {AttributeName AttributeValue} $ProcedureAttributes {
            # Evaluate the provided argument attribute
            switch -exact -- $AttributeName {
               -help {
                  # Help has been required in the procedure attribute
                  # definition list:
                  puts $ProcedureHelp
                  return
               }
               -category -
               -return -
               -short_description -
               -description -
               -named_arguments_first -
               -command_log -
               -auto_argument_name_completion -
               -example -
               -interactive_display_format {
                  # Save all these information simply in the ProcDef
                  # array variable:
                  set ProcDef($ProcName,$AttributeName) $AttributeValue
               }
               -validatecommand -
               -validatecommand_error_text {
                  lappend ProcDef($ProcName,$AttributeName) $AttributeValue
               }
               -args {
                  # Read the procedure arguments with ProcedureArgDef
                  set Comment ""
                  set SectionComment ""
                  foreach arg $AttributeValue {
                     set ErrorMsg [ProcedureArgDef $arg]
                     if {$ErrorMsg ne ""} {
                        return -code error \
                           "Procedure declaration [PureProcName -appo]: $ErrorMsg"
                     }
                  }
               }
               default {
                  return -code error \
                     "Procedure declaration [PureProcName -appo]: Procedure attribute '$AttributeName' not known"
               }
            }
         }

         # Complete the procedure attributes -
         # Number of arguments:
         set ProcDef($ProcName,NbrVars) [llength $ProcDef($ProcName,VarList)]
         # Number of named arguments
         set ProcDef($ProcName,NbrNamedVars) \
            [llength $ProcDef($ProcName,NamedVarList)]
         # Number of unnamed arguments
         set ProcDef($ProcName,NbrUnnamedVars) \
            [llength $ProcDef($ProcName,UnnamedVarList)]

      #### Create the TCL procedure(s) ####

         # Create now the TCL procedures. In case a sub procedure is
         # declared, the created TCL procedure has not to call the
         # argument evaluator, since this one has already been called
         # in the main procedure. An additional main procedure is created
         # if a sub procedure is  declared and if no main procedure is
         # existing.

         set Body    "::tepam::ProcedureArgumentEvaluation;\n"
         append Body "if {\$ProcedureArgumentEvaluationResult ne \"\"} \{\n"
         append Body "  if {\$ProcedureArgumentEvaluationResult eq \"cancel\"} return\n"
         append Body "  return -code error \$ProcedureArgumentEvaluationResult\n"
         append Body "\}\n"
         append Body "if {\$SubProcedure ne \"\"} {return \[\$SubProcedure\]}\n\n"

         if {[llength $ProcName] == 1} {
            append Body "$ProcedureBody"
            proc $ProcName {args} $Body
         } else {
            proc $ProcName {args} "uplevel 1 \{\n$ProcedureBody\n\}"
            if {[info commands [lindex $ProcName 0]] eq ""} {
               append Body "return -code error \"'[lindex $ProcName 0]' requires a subcommand\""
               proc [lindex $ProcName 0] {args} $Body
            }
         }
   }

   # ProcedureArgDef reads the definition of a single argument that is
   # provided in form of a list:
   #
   #    -mtype -default Warning -choices {Info Warning Error} -description "M. type"
   #
   # ProcedureArgDef is executed by 'procedure'. The argument definition
   # is provided via the argument 'ArgDef' variable. ProcedureArgDef is
   # recognizing argument comments and section comments that can be placed
   # into the argument definitions. ProcedureArgDef is also checking
   # the validity of the argument specifications.

   proc ProcedureArgDef {ArgDef} {
      variable ProcDef
      variable ProcedureHelp
      variable named_arguments_first
      variable command_log
................................................................................
      upvar Comment Comment
      upvar SectionComment SectionComment
      upvar UnnamedHasToBeOptional UnnamedHasToBeOptional
      upvar UnnamedWasMultiple UnnamedWasMultiple

      # Read the argument name:
      set Opt [lindex $ArgDef 0]

      #### Handle section and argument comments, parse the option name ####

         # Check if the argument definition is a simply argument
         # comment (either -, "" or {})
         if {$Opt eq "" || $Opt eq "-"} {
            # Eliminate the entire first word as well as any leading
            # and tailing white spaces
            regexp {^\s*[^\s]+\s+(.*)\s*$} $ArgDef {} Comment
            regsub -all "\"" $Comment "\\\"" Comment
            return ""

         # Check if the argument definition is an argument section begin
         } elseif {[string index $Opt 0] eq "\#"} {
            # Eliminate leading and tailing white spaces
            set SectionComment [string trim [string range $ArgDef 1 end]]

            # Eliminate the leading and ending #s and white spaces
            regexp {^\s*\#+\s*(.*?)\s*\#*\s*$} $ArgDef {} SectionComment
            # regsub -all "\"" $SectionComment "\\\" SectionComment

            # For an eventual interactive call that requires a GUI,
            # swap to the short representation mode, since the frames
            # are used to display the sections:
            set ProcDef($ProcName,-interactive_display_format) "short"
            return ""

         # Check if the argument is an option or a flag (named argument),
         # that has with a leading '-':
         } elseif {[string index $Opt 0] eq "-"} {
            set Var [string range $Opt 1 end]
            lappend ProcDef($ProcName,NamedVarList) $Var
            set ProcDef($ProcName,Arg,$Var,IsNamed) 1

         # The argument is an unnamed argument:
         } else {
            set Var $Opt
            lappend ProcDef($ProcName,UnnamedVarList) $Var
            set ProcDef($ProcName,Arg,$Var,IsNamed) 0
         }

         # Assign to the argument an eventually previously defined
         # section or argument comment:
         if {$SectionComment ne ""} {
            set ProcDef($ProcName,Arg,$Var,SectionComment) $SectionComment
            set SectionComment ""
         }
         if {$Comment ne ""} {
            set ProcDef($ProcName,Arg,$Var,Comment) $Comment
            set Comment ""
         }

         # Check that an argument is not declared multiple times:
         if {[lsearch -exact $ProcDef($ProcName,VarList) $Var]>=0} {
            return "Argument '$Var' defined multiple times"
         }

      #### Define the argument attributes ####

         # Append the argument to the argument list and define the argument
         # attributes with the default values:
         lappend ProcDef($ProcName,VarList) $Var
         set ProcDef($ProcName,Arg,$Var,-type) ""; # Undefined
         set ProcDef($ProcName,Arg,$Var,-optional) 0
         set ProcDef($ProcName,Arg,$Var,HasDefault) 0
         set ProcDef($ProcName,Arg,$Var,-multiple) 0

         # Parse all argument attribute definitions:
         for {set a 1} {$a<[llength $ArgDef]} {incr a} {
            set ArgOption [lindex $ArgDef $a]
            set ArgOptionValue [lindex $ArgDef [expr {$a+1}]]
            switch -- $ArgOption {
               -type {
                  # Argument type definition: Check if the validation
                  # command is defined for the used argument type:
                  if {[catch {Validate($ArgOptionValue) ""}]} {
                     return "Argument type '$ArgOptionValue' not known"
                  }

                  # Store the attribute type:
                  set ProcDef($ProcName,Arg,$Var,-type) $ArgOptionValue

                  # Flags (argument that have the type 'none') are
                  # always optional:
                  if {$ProcDef($ProcName,Arg,$Var,-type) eq "none"} {
                     set ProcDef($ProcName,Arg,$Var,-optional) 1
                  }
                  incr a
               }

               -default {
                  # Arguments that have default values are always optional:
                  set ProcDef($ProcName,Arg,$Var,-default) $ArgOptionValue
                  set ProcDef($ProcName,Arg,$Var,HasDefault) 1
                  set ProcDef($ProcName,Arg,$Var,-optional) 1
                  incr a
               }

               -mandatory {
                  # The -mandatory attribute is already the default behavior
               }

               -optional -
               -multiple {
                  # These attributes (flags) have just to be stored for
                  # future usage:
                  set ProcDef($ProcName,Arg,$Var,$ArgOption) 1
               }

               -range {
                  # Check that the range is defined by two values and
                  # that the min value is smaller than the max value:
                  if {[llength $ArgOptionValue] != 2 || \
                      ![Validate(double) [lindex $ArgOptionValue 0]] || \
                      ![Validate(double) [lindex $ArgOptionValue 1]]} {
                     return  "Invalid range definition - $ArgOptionValue"
                  }
                  set ProcDef($ProcName,Arg,$Var,$ArgOption) $ArgOptionValue
                  incr a
               }

               -validatecommand -
               -validatecommand_error_text -
               -auxargs_commands -
               -auxargs -
               -description -
               -choices -
               -choicelabels -
               -widget {
                  # Also these attributes have just to be stored for
                  # future usage:
                  set ProcDef($ProcName,Arg,$Var,$ArgOption) $ArgOptionValue
                  incr a
               }

               default {
                  # Generate an error if the provided attribute name
                  # doesn't match with a known attribute.
                  return "Argument attribute '$ArgOption' not known"
               }
            }
         }

      #### Perform various argument attribute validation checks ####

         # Unnamed argument attribute checks:
         if {!$ProcDef($ProcName,Arg,$Var,IsNamed)} {
            # Check that behind an optional unnamed argumeent there are
            # only other optional unnamed arguments:
            if {$UnnamedHasToBeOptional && !$ProcDef($ProcName,Arg,$Var,-optional)} {
               return "Argument '$Var' has to be optional"
            }

            # Check that only the last unnamed argument can take multiple
            # values:
            if {$UnnamedWasMultiple} {
               return "Attribute '-multiple' is only for the last unnamed argument allowed"
            }

            # Check the length of an optional -choicelabels list
            if {[info exists ProcDef($ProcName,Arg,$Var,-choices)] && \
                [info exists ProcDef($ProcName,Arg,$Var,-choicelabels)]} {
               if {[llength $ProcDef($ProcName,Arg,$Var,-choices)] !=
                   [llength $ProcDef($ProcName,Arg,$Var,-choicelabels)]} {
                  return "Argument '$Var' - Choice label list and choice list have different sizes"
               }
            }

            # Store the information about the argument attributes the
            # check the consistency of the following arguments:
            if {$ProcDef($ProcName,Arg,$Var,-optional)} {
               set UnnamedHasToBeOptional 1
            }
            if {$ProcDef($ProcName,Arg,$Var,-multiple)} {
               set UnnamedWasMultiple 1
            }
         }

         # Range checks are only allowed for integers and doubles:
         if {[info exists ProcDef($ProcName,Arg,$Var,-range)]} {
            if {[lsearch {integer double} $ProcDef($ProcName,Arg,$Var,-type)]<0} {
               return "Argument '$Var' - range specification requires type integer or double"
            }
         }

      return ""
   }

   ######## ProcedureArgumentEvaluation ########

   # ProcedureArgumentEvaluation is the argument evaluator that is
   # embedded by the procedure declaration command 'procedure' into
   # the procedure body in the following way:
   #
   #    proc my_proc {args} {
   #       ::tepam::ProcedureArgumentEvaluation;
   #       if {$ProcedureArgumentEvaluationResult ne ""} {
   #         if {$ProcedureArgumentEvaluationResult eq "cancel"} return
   #         return -code error $ProcedureArgumentEvaluationResult;
   #       }
   #       if {$SubProcedure ne ""} {return [$SubProcedure]};
   #
   #       puts $message; # Procedure body
   #    }
   #
   # ProcedureArgumentEvaluation has to define in the calling procedure
   # two variables:
   # The first one is ProcedureArgumentEvaluationResult that has to
   # contain the result of the evaluation and validation of the argument
   # set. Zero as results means that the provided arguments are OK and
   # that the procedure body can be executed. A non-zero value indicates
   # that the procedure body has not to be evaluated, typically because
   # help was requested via the -help option. In case of incorrect
   # arguments an error is generated by ProcedureArgumentEvaluation.
   # The second variable that is created by ProcedureArgumentEvaluation
   # is 'SubProcedure'. This variable is set to the sub procedure name
   # in case a sub procedure is called. If the main procedure is called
   # this variable is set to an empty string.

   # Delcare first a tiny helper function:
   # ProcedureArgumentEvaluationReturn will assign the
   # provided result string to the ProcedureArgumentEvaluationResult
   # variable in the context of the calling procedure and will then
   # emulate a return function.

   proc ProcedureArgumentEvaluationReturn {Result} {
      upvar 2 ProcedureArgumentEvaluationResult \
         ProcedureArgumentEvaluationResult
      set ProcedureArgumentEvaluationResult $Result
      return -code return
   }

   proc ProcedureArgumentEvaluation {} {
      variable ProcDef
      upvar args args
      upvar SubProcedure SubProcedure

      #### Extract the procedure and sub procedure names, call the procedure help if requested ####

         # Evaluate the complete main procedure name that contains the
         # namespace identification: The procedure name is given by the
         # first element of 'info level':
         set ProcedureCallLine [info level -1]
         set ProcName [lindex $ProcedureCallLine 0]

         # Create the full qualified procedure name (procedure name
         # including namespace)
         regexp {([^:]*)$} $ProcName {} ProcName
         set NameSpace [uplevel 1 {namespace current}]
         if {$NameSpace ne "::"} {append NameSpace "::"}
         set ProcName ${NameSpace}${ProcName}

         # Evaluate the sub command names by checking if the first
         # arguments are matching with a specified sub command name:
         set SubProcedure ""
         while {1} {
            set ProcNameTmp "$ProcName [lindex $args 0]"
            if {![info exists ProcDef($ProcNameTmp,VarList)] && [array names ProcDef "$ProcNameTmp *"] eq ""} {
               # The argument is not matching with a specified sub
               # command name (so it will be a real argument):
               break
            }
            # Use the argument as sub procedure name:
            set ProcName $ProcNameTmp
            set SubProcedure $ProcName
            set args [lrange $args 1 end]
         }

         # Check if help has been requested in the procedure call:
         if {[lindex $args end] eq "-help"} {
            ProcedureHelp $ProcName
            ProcedureArgumentEvaluationReturn "cancel"
         }

         # Check if the procedure call is an interactive call
         set InteractiveCall [string match "-interactive" [lindex $args end]]

         # Return an empty string if the main procedure has been
         # called and if only sub-commands have been defined, but
         # not the main procedure itself.
         if {![info exists ProcDef($ProcName,VarList)]} {
            ProcedureArgumentEvaluationReturn ""
         }

      #### Call an argument_dialogbox if the procedure has been called with '-interactive' ####
         set NewArgs {}
         if {$InteractiveCall} {
            # Generate an error if Tk hasn't been loaded
            if {[catch {package present Tk}]} {
               ProcedureArgumentEvaluationReturn \
                  "[PureProcName]: Interactive calls are only supported if Tk is loaded!"
            }
            package require tile

            # Start creating the argument_dialogbox argument list with
            # the title attribute:
            set DialogBoxArguments [list -title $ProcName -context $ProcName]

            # Add eventual global validation commands
            foreach ValidateCommand $ProcDef($ProcName,-validatecommand) {
               lappend DialogBoxArguments -validatecommand2 $ValidateCommand
            }
            foreach ValidateCommandErrorText \
               $ProcDef($ProcName,-validatecommand_error_text) {
               lappend DialogBoxArguments \
                  -validatecommand2_error_text $ValidateCommandErrorText
            }

            # Create for each of the procedure arguments an entry for
            # the argument_dialogbox:
            foreach Var $ProcDef($ProcName,VarList) {
               # Declare the result variables. These variables refer to
               # the variables in the parent procedure (upvar). Attribute
               # to these variables directly the default values that can be
               # overwritten later with the new defined values.
               upvar $Var Variable__$Var

               # Create sections, write section and argument comments:
               if {$ProcDef($ProcName,-interactive_display_format) eq "extended"} {
                  if {[info exists ProcDef($ProcName,Arg,$Var,SectionComment)]} {
                     # If a section comment is defined, close an eventual
                     # open frame, add the section comment and add an
                     # eventually defined arguement comment:
                     lappend DialogBoxArguments \
                        -frame ""; # Close an eventual open frame
                     lappend DialogBoxArguments \
                         -comment [list -text $ProcDef($ProcName,Arg,$Var,SectionComment)]
                     if {[info exists ProcDef($ProcName,Arg,$Var,Comment)]} {
                        lappend DialogBoxArguments \
                           -comment [list -text $ProcDef($ProcName,Arg,$Var,Comment)]
                     }
                  }
                  # Create a frame around each argument entry in the
                  # extended format:
                  lappend DialogBoxArguments -frame [list -label $Var]
               } elseif {[info exists ProcDef($ProcName,Arg,$Var,SectionComment)]} {
                  # If a section is defined, create a section frame in
                  # the sort format:
                  lappend DialogBoxArguments \
                     -frame [list -label $ProcDef($ProcName,Arg,$Var,SectionComment)]
               }
               # If an argument comment is defined but not yet applied,
               # apply it:
               if {[info exists ProcDef($ProcName,Arg,$Var,Comment)] &&
                   !( $ProcDef($ProcName,-interactive_display_format) eq "extended" &&
                     [info exists ProcDef($ProcName,Arg,$Var,SectionComment)] )} {
                  lappend DialogBoxArguments \
                     -comment [list -text $ProcDef($ProcName,Arg,$Var,Comment)]
               }

               # Provide to the argument dialogbox all the argument attributes:
               set ArgAttributes {}
               if {$ProcDef($ProcName,Arg,$Var,-type) ne ""} {
                  lappend ArgAttributes -type $ProcDef($ProcName,Arg,$Var,-type)
               }
               if {$ProcDef($ProcName,Arg,$Var,-optional)} {
                  lappend ArgAttributes -optional 1
               }
               if {[info exists ProcDef($ProcName,Arg,$Var,-range)] && \
                   $ProcDef($ProcName,Arg,$Var,-range) ne ""} {
                  lappend ArgAttributes -range $ProcDef($ProcName,Arg,$Var,-range)
               }
               if {[info exists ProcDef($ProcName,Arg,$Var,-validatecommand)]} {
                  lappend ArgAttributes -validatecommand $ProcDef($ProcName,Arg,$Var,-validatecommand)
               }
               if {[info exists ProcDef($ProcName,Arg,$Var,-validatecommand_error_text)]} {
                  lappend ArgAttributes -validatecommand_error_text $ProcDef($ProcName,Arg,$Var,-validatecommand_error_text)
               }
               if {[info exists ProcDef($ProcName,Arg,$Var,-auxargs)] && $ProcDef($ProcName,Arg,$Var,-auxargs) ne ""} {
                  set ArgAttributes [concat $ArgAttributes $ProcDef($ProcName,Arg,$Var,-auxargs)]
               }
               if {[info exists ProcDef($ProcName,Arg,$Var,-auxargs_commands)]} {
                  foreach {AuxArg_Name AuxArgCommand} $ProcDef($ProcName,Arg,$Var,-auxargs_commands) {
                     lappend ArgAttributes $AuxArg_Name [uplevel #1 $AuxArgCommand]
                  }
               }
................................................................................
               }

               # Set the default values
               if {[info exists ProcDef($ProcName,Arg,$Var,-default)]} {
                  lappend ArgAttributes -default $ProcDef($ProcName,Arg,$Var,-default)
               }

               # Add the variable name, type, description and range as
               # labels and comments:
               set Label $Var; # Default label
               if {$ProcDef($ProcName,-interactive_display_format) eq "extended"} {
                  # Add the argument description as comment
                  if {[info exists ProcDef($ProcName,Arg,$Var,-description)]} {
                     lappend DialogBoxArguments \
                                    -comment [list -text $ProcDef($ProcName,Arg,$Var,-description)]
                  }

                  # Add the type and ranges as comment
                  if {[lsearch {"" "string" "none"} $ProcDef($ProcName,Arg,$Var,-type)]<0} {
                     set Comment "Type: $ProcDef($ProcName,Arg,$Var,-type), "
                     if {[info exists ProcDef($ProcName,Arg,$Var,-range)]} {
                        append Comment "range: [lindex $ProcDef($ProcName,Arg,$Var,-range) 0] .."
                        append Comment " [lindex $ProcDef($ProcName,Arg,$Var,-range) 1], "
                     }
                     lappend DialogBoxArguments -comment [list -text [string range $Comment 0 end-2]]
                  }
               } else {
                  if {[info exists ProcDef($ProcName,Arg,$Var,-description)]} {
                     set Label $ProcDef($ProcName,Arg,$Var,-description)
                  }
               }

               # Select the adequate widget for the argument:
               lappend ArgAttributes -label "$Label:" -variable Variable__$Var

               # A specific entry widget is explicitly specified:
               if {[info exists ProcDef($ProcName,Arg,$Var,-widget)]} {
                  lappend DialogBoxArguments \
                     -$ProcDef($ProcName,Arg,$Var,-widget) $ArgAttributes

               # A type specific widget exists, so use this one:
               } elseif {[info procs ad_form($ProcDef($ProcName,Arg,$Var,-type))] ne ""} {
                  lappend DialogBoxArguments -$ProcDef($ProcName,Arg,$Var,-type) $ArgAttributes

               # Use a simple checkbutton for flags:
               } elseif {$ProcDef($ProcName,Arg,$Var,-type) eq "none"} {
                  lappend DialogBoxArguments -checkbutton $ArgAttributes

               # A choice list is provided with less or equal than 4
               # options, use radioboxes or checkboxes:
               } elseif {[info exists ProcDef($ProcName,Arg,$Var,-choices)] && \
                   [llength $ProcDef($ProcName,Arg,$Var,-choices)]<=4} {
                  if {$ProcDef($ProcName,Arg,$Var,-multiple)} {
                     lappend DialogBoxArguments -checkbox [concat [list \
                        -choices $ProcDef($ProcName,Arg,$Var,-choices)] $ArgAttributes]
                  } else {
                     lappend DialogBoxArguments -radiobox [concat [list \
                        -choices $ProcDef($ProcName,Arg,$Var,-choices)] $ArgAttributes]
                  }

               # A choice list is provided with less than 30 options,
               # use a listbox or a disjointlistbox:
               } elseif {[info exists ProcDef($ProcName,Arg,$Var,-choices)] && \
                         [llength $ProcDef($ProcName,Arg,$Var,-choices)]<30} {
                  if {$ProcDef($ProcName,Arg,$Var,-multiple)} {
                     lappend DialogBoxArguments -disjointlistbox [concat [list \
                        -choicevariable ProcDef($ProcName,Arg,$Var,-choices) \
                        -height 3] $ArgAttributes]
                  } else {
                     lappend DialogBoxArguments -listbox [concat [list \
                        -choicevariable ProcDef($ProcName,Arg,$Var,-choices) \
                        -height 3] $ArgAttributes]
                  }

               # For all other cases, use a simple entry widget:
               } else {
                  lappend DialogBoxArguments -entry $ArgAttributes
               }
            }

            # Call the argument dialogbox
            # puts "argument_dialogbox \{$DialogBoxArguments\}"
            if {[argument_dialogbox $DialogBoxArguments] eq "cancel"} {
               # The argument dialogbox has been canceled, leave the
               # calling procedure without executing the procedure body:
               ProcedureArgumentEvaluationReturn cancel
            }

            # Set the variables of the optional arguments to the
            # default values, if the variables haven't been defined
            # by the argument dialogbox:
            foreach Var $ProcDef($ProcName,VarList) {
               if {![info exists Variable__$Var] && \
                    [info exists ProcDef($ProcName,Arg,$Var,-default)]} {
                     set Variable__$Var $ProcDef($ProcName,Arg,$Var,-default)
               }
            }

      #### Non interactive call: Parse all arguments and define the argument variables ####

         } else {

            # Result variable declaration and default value definition
            foreach Var $ProcDef($ProcName,VarList) {
               # Declare the result variables. These variables refer
               # to the variables in the parent procedure (upvar).
               # Attribute to these variables directly the default
               # values that can be overwritten later with the new
               # defined values.
               upvar $Var Variable__$Var

               # Set the flags to the default values only when the
               # procedure is called interactively:
               if {$ProcDef($ProcName,Arg,$Var,-type) eq "none"} {
                  set Variable__$Var 0
               } elseif {[info exists ProcDef($ProcName,Arg,$Var,-default)]} {
                  # Apply an eventually defined default value,
                  # in case the argument is not a flag:
                  set Variable__$Var $ProcDef($ProcName,Arg,$Var,-default)
               }
            }

            # Prepare parsing all arguments
            set NbrArgs [llength $args]; # Number of provided arguments
            set NumberUnnamedArgs 0
            set ArgPos 0

            # Parse the unnamed arguments if they are defined first
            # and if some of them have been declared:
            if {!$ProcDef($ProcName,-named_arguments_first)} {
               # Parse all unnamed arguments. Stop parsing them when:
               # 1) all unnamed arguments that have been declared have
               #    been parsed && the last unnamed argument has not
               #    the -multiple option &&
               # 2) the parsed argument is optional and starts with '-'
               # 3) the parsed argument has can take multiple values &&
               #    one value has already been read &&
               #    the parsed argument starts with '-'

               # An argument value is optional when it has been declared
               # with the -optional option or when it is declared with
               # the -multiple option and already one value has been
               # attributed to the argument:
               set IsOptional 0

               # Loop through all arguments (only if unnamed arguments
               # have been declared):
               for {} {$ArgPos<[llength $args] && $ProcDef($ProcName,NbrUnnamedVars)>0} {incr ArgPos} {
                  # Get the next provided parameter value:
                  set arg [lindex $args $ArgPos]

                  # The ordered unnamed argument list provides the
                  # relevant argument:
                  set Var [lindex $ProcDef($ProcName,UnnamedVarList) $NumberUnnamedArgs]

                  # Stop parsing the unnamed arguments, if the procedure
                  # has also named arguments, if the argument to parse is
                  # optional, and if it starts with '-':
                  if {$ProcDef($ProcName,Arg,$Var,-optional)} {
                     set IsOptional 1
                  }
                  if {$ProcDef($ProcName,NbrNamedVars)>0 && $IsOptional && \
                      [string index $arg 0] eq "-"} {
                     break
                  }

                  # If the argument can have multiple values: Don't update
                  # the unnamed argument counter to attribute the next
                  # values to the same argument. Declare the next values
                  # also as optional
                  if {$ProcDef($ProcName,Arg,$Var,-multiple)} {
                     lappend Variable__$Var $arg
                     set IsOptional 1

                  # Otherwise (the argument cannot have multiple values),
                  # assign the value to the variable. Exit the unnamed
                  # argument loop when the last declared argument has
                  # been read:
                  } else {
                     set Variable__$Var $arg
                     incr NumberUnnamedArgs
                     if {$NumberUnnamedArgs == $ProcDef($ProcName,NbrUnnamedVars)} {
                        incr ArgPos
                        break
                     }
                  }
               }

               # Create an error if there are other argument values
               # that are provided, but when no named arguments are declared:
               if {$ProcDef($ProcName,NbrNamedVars) == 0 && $ArgPos < [llength $args]} {
                  ProcedureArgumentEvaluationReturn \
                     "$ProcName: Too many arguments: [lrange $args $ArgPos end]"
               }
            }

            # Parse the named arguments
            for {} {$ArgPos<[llength $args]} {incr ArgPos} {
               # Get the argument name:
               set arg [lindex $args $ArgPos]

               # Ignore the '--' flag. Exit the named argument
               # parsing loop if 'named arguments first' is configured
               if {$arg eq "--"} {
                  if {$ProcDef($ProcName,-named_arguments_first)} {
                     incr ArgPos
                     break
                  } else {
                     continue
                  }
               }

               # In case the named arguments are used first: Check if
               # the next argument is not anymore a named argument and
               # stop parsing the named arguments if this is the case.
               if {$ProcDef($ProcName,-named_arguments_first) && [string index $arg 0] ne "-"} {
                  break
               }

               # Otherwise (especially if the unnamed arguments are used
               # first), check that the option name starts with '-':
               if {[string index $arg 0] ne "-"} {
                  ProcedureArgumentEvaluationReturn \
                     "[PureProcName]: Argument '$arg' is not an option"
               }

               # Extract the variable name (eliminate the '-'):
               set Var [string range $arg 1 end]

               # Check if the variable (name) is known. When it is not
               # known, complete it when the name matches with the begin
               # of a known variable name, or generate otherwise an error:

               if {![info exists ProcDef($ProcName,Arg,$Var,-type)]} {

                  # Argument completion is disabled - generate an error:
                  if {!$ProcDef($ProcName,-auto_argument_name_completion)} {
                     ProcedureArgumentEvaluationReturn \
                        "[PureProcName -appr]: Argument '-$Var' not known"

                  # Argument completion is enabled - check if the variable
                  # name corresponds to the begin of a known argument name:
                  } else {
                     # set MatchingVarList [lsearch -all -inline -glob $ProcDef($ProcName,VarList) ${Var}*] -> Tcl 8.3 doesn't support the -all and -inline switches!
                     set MatchingVarList {}
                     set VarList $ProcDef($ProcName,VarList)
                     while {[set Pos [lsearch -glob $VarList ${Var}*]]>=0} {
                        lappend MatchingVarList [lindex $VarList $Pos]
                        set VarList [lrange $VarList [expr {$Pos+1}] end]
                     }
                     # Complete the argument name if the argument doesn't
                     # exist, but if it is the begin of a declared argument.
                     switch [llength $MatchingVarList] {
                        1 {
                           set Var $MatchingVarList
                        }
                        0 {
                           ProcedureArgumentEvaluationReturn \
                              "[PureProcName]: Argument '-$Var' not known"
                        }
                        default {
                           ProcedureArgumentEvaluationReturn \
                              "[PureProcName]: Argument '-$Var' may match multiple options: $MatchingVarList"
                        }
                     }
                  }
               }

               # Set the variable value to '1' if the argument is a
               # flag (type is 'none'). Read  otherwise the variable value:
               if {$ProcDef($ProcName,Arg,$Var,-type) eq "none"} {
                  # The argument is a flag
                  set Value 1

               # No argument value is provided - generate an error:
               } elseif {$ArgPos == [llength $args] - 1} {
                  ProcedureArgumentEvaluationReturn \
                     "[PureProcName]: No value is provided for argument '-$Var'"

               # Read the argument value
               } else {
                  set Value [lindex $args [incr ArgPos]]
               }

               # Define the argument variable. Append the new value to
               # the existing value of the variable, if the '-multiple'
               # attribute is set for the argument:
               if {$ProcDef($ProcName,Arg,$Var,-multiple)} {
                  lappend Variable__$Var $Value
               } else {
                  set Variable__$Var $Value
               }
            }

            # In case the unnamed arguments are defined last, parse them now:
            if {$ProcDef($ProcName,-named_arguments_first)} {

               # Loop through the remaining arguments:
               for {} {$ArgPos<[llength $args]} {incr ArgPos} {
                  # Get the next provided parameter value:
                  set arg [lindex $args $ArgPos]
                  # Assure that the number of provided arguments is not \
                  # exceeding the total number of declared unnamed arguments:
                  if {$NumberUnnamedArgs>=$ProcDef($ProcName,NbrUnnamedVars)} {
                     # Too many unnamed arguments are used, generate
                     # an adequate error message:
                     if {[string index $arg 0] eq "-"} {
                        ProcedureArgumentEvaluationReturn \
                           "[PureProcName]: Too many unnamed arguments, or incorrectly used named argument: $arg"
                     } else {
                        ProcedureArgumentEvaluationReturn \
                           "[PureProcName]: Too many unnamed arguments: $arg"
                     }
                  }

                  # The ordered unnamed argument list provides the relevant
                  # argument:
                  set Var [lindex $ProcDef($ProcName,UnnamedVarList) $NumberUnnamedArgs]

                  # Assign all remaining parameter values to the last
                  # argument if this one can take multiple values:
                  if {$ProcDef($ProcName,Arg,$Var,-multiple) &&
                     $NumberUnnamedArgs == $ProcDef($ProcName,NbrUnnamedVars) - 1} {
                     set Variable__$Var [lrange $args $ArgPos end]
                     # incr NumberUnnamedArgs
                     set ArgPos [llength $args]

                  # Assign otherwise the parameter value to the actual argument
                  } else {
                     set Variable__$Var $arg
................................................................................
                  }
               }
            }
         }

      #### Argument validation ####

         # Check that all mandatory arguments have been defined and
         # that all arguments satisfy the defined type:

         # Loop through all named and unnamed arguments:
         foreach Var $ProcDef($ProcName,VarList) {

            # An error is created when a variable is not optional
            # and when it is not defined:
            if {!$ProcDef($ProcName,Arg,$Var,-optional) && ![info exists Variable__$Var]} {
               ProcedureArgumentEvaluationReturn \
                  "[PureProcName]: Required argument is missing: $Var"
            }

            # Check the variable value corresponds to the specified type:
            if {[info exists Variable__$Var]} {
               # Transform the variable value in a list in case the
               # argument is not multiple definable:
               set ValueList [set Variable__$Var]
               if {!$ProcDef($ProcName,Arg,$Var,-multiple)} {
                  set ValueList [list $ValueList]
               }

               # Loop through all elements of this list and check
               # if each element is valid:
               foreach Value $ValueList {
                  # Check the argument type:
                  if {![Validate($ProcDef($ProcName,Arg,$Var,-type)) $Value]} {
                     ProcedureArgumentEvaluationReturn \
                        "[PureProcName]: Argument '$Var' requires type '$ProcDef($ProcName,Arg,$Var,-type)'. Provided value: '$Value'"
                  }

                  # Check the argument with an eventually defined
                  # validation command:
                  if {[info exists ProcDef($ProcName,Arg,$Var,-validatecommand)]} {
                     regsub {%P} $ProcDef($ProcName,Arg,$Var,-validatecommand) $Value ValidateCommand
                     if {![uplevel $ValidateCommand]} {
                        if {[info exists ProcDef($ProcName,Arg,$Var,-validatecommand_error_text)]} {
                           ProcedureArgumentEvaluationReturn \
                              "[PureProcName]: $ProcDef($ProcName,Arg,$Var,-validatecommand_error_text)"
                        } else {
                           ProcedureArgumentEvaluationReturn \
                              "[PureProcName]: Argument '$Var' is invalid. Provided value: '$Value'. Constraint: '$ProcDef($ProcName,Arg,$Var,-validatecommand)'"
                        }
                     }
                  }

                  # Check if the variable value satisfies an eventually
                  # defined range:
                  if {[info exists ProcDef($ProcName,Arg,$Var,-range)]} {
                     if {$Value<[lindex $ProcDef($ProcName,Arg,$Var,-range) 0] || \
                         $Value>[lindex $ProcDef($ProcName,Arg,$Var,-range) 1]} {
                        ProcedureArgumentEvaluationReturn \
                           "[PureProcName]: Argument '$Var' has to be between [lindex $ProcDef($ProcName,Arg,$Var,-range) 0] and [lindex $ProcDef($ProcName,Arg,$Var,-range) 1]"
                     }
                  }

                  # Check the variable value is a member of a provided
                  # choice list:
                  if {[info exists ProcDef($ProcName,Arg,$Var,-choices)]} {
                     if {[lsearch -exact $ProcDef($ProcName,Arg,$Var,-choices) $Value]<0} {
                        ProcedureArgumentEvaluationReturn \
                           "[PureProcName]: Argument '$Var' has to be one of the following elements: [GetChoiceHelpText $ProcName $Var]"
                     }
                  }
               }
            }
         }

      #### Procedure level validation ####

         foreach ValidateCommand $ProcDef($ProcName,-validatecommand) \
            ValidateCommandErrorText $ProcDef($ProcName,-validatecommand_error_text) {
            # regsub {%P} $ProcDef($ProcName,Arg,$Var,-validatecommand) $Value ValidateCommand
            if {![uplevel $ValidateCommand]} {
               if {$ValidateCommandErrorText ne ""} {
                  ProcedureArgumentEvaluationReturn \
                     "[PureProcName]: $ValidateCommandErrorText"
               } else {
                  ProcedureArgumentEvaluationReturn \
                     "[PureProcName]: Invalid argument(s) provided. Constraint: '$ValidateCommand'"
               }
            }
         }

      #### Log the procedure call ####

         variable ProcedureCallLogList

         if {$InteractiveCall && $ProcDef($ProcName,-command_log) eq "interactive"} {
            append ProcedureCallLogList $ProcName
            if {$ProcDef($ProcName,-named_arguments_first)} {
               set ParClasses {Named Unnamed}
            } else {
               set ParClasses {Unnamed Named}
            }
            foreach ParClass $ParClasses {
               foreach Var $ProcDef($ProcName,${ParClass}VarList) {
                  if {![info exists Variable__$Var]} continue; # Skip optional arguments that haven't been defined
                  if {$ProcDef($ProcName,Arg,$Var,-type) ne "none"} { # Non flag arguments
                     if {$ProcDef($ProcName,Arg,$Var,IsNamed)} {
                        append ProcedureCallLogList " -$Var"
                     }
                     append ProcedureCallLogList " \{[set Variable__$Var]\}"
                  } elseif {[set Variable__$Var]} { # Flags that are set
                     append ProcedureCallLogList " -$Var"
                  }
               }
            }
            append ProcedureCallLogList "; \# interactive call\n"
         } elseif {$ProcDef($ProcName,-command_log) eq "1"} {
            append ProcedureCallLogList "$ProcedureCallLine\n"
         }

      ProcedureArgumentEvaluationReturn ""
   }

   ######## Validation commands ########

   # For each of the standard argument types supported by TEPAM,
   # the validation command 'Validate(<Type>)' specified in the
   # following section. These commands have to return '1' in
   # case the provided value correspond to the relevant type and
   # '0' if not. Additional user or application specific types
   # can easily be supported simply by adding a validation command
   # for the new type into the 'tepam' namespace.

   proc Validate()         {v} {return 1}
   proc Validate(none)     {v} {return 1}
   proc Validate(string)   {v} {return 1}
   proc Validate(text)     {v} {return 1}
   proc Validate(boolean)  {v} {string is boolean -strict $v}
................................................................................
   proc Validate(lower)    {v} {string is lower $v}
   proc Validate(print)    {v} {string is print $v}
   proc Validate(punct)    {v} {string is punct $v}
   proc Validate(space)    {v} {string is space $v}
   proc Validate(upper)    {v} {string is upper $v}
   proc Validate(wordchar) {v} {string is wordchar $v}
   proc Validate(xdigit)   {v} {string is xdigit $v}
   proc Validate(char)     {v} {expr {[string length $v]==1}}
   proc Validate(color)    {v} {expr {![catch {winfo rgb . $v}]}}
   proc Validate(font)     {v} {expr {![catch {font measure $v ""}]}}
   proc Validate(file)              {v} {expr {[string length $v]>0 && ![regexp {[\"*?<>]} $v]}}
   proc Validate(existingfile)      {v} {file exists $v}
   proc Validate(directory)         {v} {return 1}
   proc Validate(existingdirectory) {v} {file isdirectory $v}

   ######## Help text generation ########

   # 'ProcedureHelp_Append' appends a piece of text to the existing
   # HelpText variable of the calling context (procedure). Tabulator
   # characters are replaced through 3 spaces. Lines are reformatted
   # to respect the maximum allowed line length. In case a line is
   # wrapped, the leading spaces of the first line are added to the
   # begin of the following lines. Multiple lines can be provided as
   # text piece and these multiple lines are handled independently
   # each to another.

   proc ProcedureHelp_Append {Text} {
      upvar HelpText HelpText
      variable help_line_length

      # Replace tabs through 3 spaces:
      regsub -all {\t} $Text "   " Text

      # Extract the initial spaces of the first line:
      regexp {^(\s*)} $Text {} SpaceStart

      # Loop through each of the provided help text line:
      foreach line [split $Text "\n"] {

         # Eliminate leading spaces of the line:
         regexp {^\s+'*(.*)$} $line {} line

         # Cut the line into segments that doesn't exceed the maximum
         # allowed help line length. Add in front of each new line the
         # initial spaces of the first line:
         while {$line ne ""} {
            # Align the leading line spaces to the first line:
            set line ${SpaceStart}${line}

            #### Next line cutoff position evaluation ####

            # Select the next line cut position. The default position
            # is set to the line end:
            set LastPos [string length $line]
            # Search for the last space inside the line section that
            # is inside the specified maximum line length:
            if {$LastPos>$help_line_length} {
               set LastPos [string last " " $line $help_line_length]
            }
            # If the evaluated line break position is inside the
            # range of the initial line spaces, something goes wrong
            # and the line should be broken at another adequate character:
            if {$LastPos<=[string length $SpaceStart]-1} {
               # Search for other good line break characters (:
               set LastPos [lindex [lindex \
                  [regexp -inline -indices {[^,:\.?\)]+$} \
                  {ProcDef(::ImportTestPointAssignmentsGeneric,Arg_SectionComment,ColumnSeparation}] 0] 0]
               # No line break position could be found:
               if {$LastPos eq {}} {set LinePos 0}
            }
            # Break the line simply at the maximum allowed length
            # in case no break position could be found:
            if {$LastPos<=[string length $SpaceStart]-1} {
               set LastPos $help_line_length
            }

            # Add the line segment to the help text:
            append HelpText [string range $line 0 [expr {$LastPos-1}]]\n

            # Eliminate the segment from the actual line:
            set line [string range $line [expr {$LastPos+1}] end]
         }
      }
   }

   # GetChoiceHelpText returns a help text for the choice options.
   # The returned string corresponds to the comma separated choice
   # list in case no choice labels are defined. Otherwise, the
   # choice labels are added behind the choice options in paranthesis.

   proc GetChoiceHelpText {ProcName Var} {
      variable ProcDef
      set ChoiceHelpText ""
      set LabelList {}
      catch {set LabelList $ProcDef($ProcName,Arg,$Var,-choicelabels)}
      foreach Choice $ProcDef($ProcName,Arg,$Var,-choices) Label $LabelList {
         append ChoiceHelpText ", $Choice"
         if {$Label ne ""} {
            append ChoiceHelpText "($Label)"
         }
      }
      return [string range $ChoiceHelpText 2 end]
   }

   # 'ProcedureHelp' behaves in different ways, depending the provided
   # argument. Called without any argument, it summarizes all the
   # declared procedures without explaining details about the procedure
   # arguments. Called with a particular procedure name as parameter,
   # it produces for this procedure a comprehensive help text. And
   # finally, if it is called with the name of a main procedure that
   # has multiple sub procedures, it generates for all the sub procedures
   # the complete help text.

   proc ProcedureHelp {{ProcName ""} {ReturnHelp 0}} {
      variable ProcDef
      variable ProcedureList
      ProcedureHelp_Append "NAME"

      # Print a list of available commands when no procedure name has
      # been provided as argument:
      if {$ProcName eq ""} {
         foreach ProcName [lsort -dictionary $ProcedureList] {
            if {[info exists ProcDef($ProcName,-short_description)]} {
               ProcedureHelp_Append "      [PureProcName] - $ProcDef($ProcName,-short_description)"
            } else {
               ProcedureHelp_Append "      [PureProcName]"
            }
         }

      # A procedure name has been provided, generate a detailed help
      # text for this procedure, or for all sub procedures if only the
      # main procedure names has been provided:
      } else {
         # Create the full qualified procedure name (procedure name
         # including namespace). Check if the procedure name contains
         # already the name space identification:
         if {[string range $ProcName 0 1] ne "::"} {
            # The namespace is not part of the used procedure
            # name call. Evaluate it explicitly:
            set NameSpace [uplevel 1 {namespace current}]
            if {$NameSpace ne "::"} {append NameSpace "::"}
            set ProcName ${NameSpace}${ProcName}
         }
         set PureProcName [PureProcName]

         # Add the short description if it exists to the NAME help
         # text section. Please note that only the short description
         # of a main procedure is used in case the procedure has also
         # sub procedures.
         if {[info exists ProcDef($ProcName,-short_description)]} {
            ProcedureHelp_Append "      $PureProcName - $ProcDef($ProcName,-short_description)"
         } else {
            ProcedureHelp_Append "      $PureProcName"
         }

         # Create the SYNOPSIS section which contains also the synopsis
         # of eventual sub procedures:
         ProcedureHelp_Append "SYNOPSIS"
         set NbrDescriptions 0
         set NbrExamples 0

         # Loop through all procedures and sub procedures:
         set ProcNames [lsort -dictionary [concat [list $ProcName] [info procs "$ProcName *"]]]
         foreach ProcName $ProcNames {
            # Skip the (sub) procedure if it has not been explicitly
            # declared. This may be the case for procedures that are
            # not implemented themselves but which have sub procedures:
            if {![info exists ProcDef($ProcName,VarList)]} continue
            set PureProcName [PureProcName]

            # Add to the help text first the procedure name, and then
            # in the following lines its arguments:
            ProcedureHelp_Append "      $PureProcName"
            if {$ProcDef($ProcName,-named_arguments_first)} {
               set ParClasses {Named Unnamed}
            } else {
               set ParClasses {Unnamed Named}
            }
            foreach ParClass $ParClasses {
               foreach Var $ProcDef($ProcName,${ParClass}VarList) {
                  # Section comment: Create a clean separation of the arguments:
                  if {[info exists ProcDef($ProcName,Arg,$Var,SectionComment)]} {
                     ProcedureHelp_Append "         --- $ProcDef($ProcName,Arg,$Var,SectionComment) ---"
                  }

                  # Argument declaration - put optional arguments into
                  # brackets, show the name of named arguments, add
                  # existing descriptions as well as range, type, choice
                  # definitions:
                  set HelpLine "            "
                  if {$ProcDef($ProcName,Arg,$Var,-optional)} {
                     append HelpLine "\["
                  }
                  if {$ProcDef($ProcName,Arg,$Var,IsNamed)} {
                     append HelpLine "-$Var "
                  }
                  if {$ProcDef($ProcName,Arg,$Var,-type) ne "none"} {
                     append HelpLine "<$Var>"
                  }
                  if {$ProcDef($ProcName,Arg,$Var,-optional)} {
                     append HelpLine "\]"
                  }
                  ProcedureHelp_Append $HelpLine

................................................................................
                  if {[info exists ProcDef($ProcName,Arg,$Var,-description)]} {
                     append HelpLine "$ProcDef($ProcName,Arg,$Var,-description), "
                  }
                  if {[lsearch -exact {"" "none"} $ProcDef($ProcName,Arg,$Var,-type)]<0} {
                     append HelpLine "type: $ProcDef($ProcName,Arg,$Var,-type), "
                  }
                  if {[info exists ProcDef($ProcName,Arg,$Var,-default)]} {
                     if {[lsearch -exact {"" "string"} $ProcDef($ProcName,Arg,$Var,-type)]>=0 ||
                         $ProcDef($ProcName,Arg,$Var,-default) eq ""} {
                        append HelpLine "default: \"$ProcDef($ProcName,Arg,$Var,-default)\", "
                     } else {
                        append HelpLine "default: $ProcDef($ProcName,Arg,$Var,-default), "
                     }
                  }
                  if {$ProcDef($ProcName,Arg,$Var,-multiple)} {
                     append HelpLine "multiple: yes, "
................................................................................
                  if {[info exists ProcDef($ProcName,Arg,$Var,-choices)]} {
                     append HelpLine "choices: \{[GetChoiceHelpText $ProcName $Var]\}, "
                  }
                  # Eliminate the last ", ":
                  ProcedureHelp_Append [string range $HelpLine 0 end-2]
               }
            }
            # Remember if descriptions and/or examples are provided
            # for the procedure:
            if {[info exists ProcDef($ProcName,-description)]} {
               incr NbrDescriptions
            }
            if {[info exists ProcDef($ProcName,-example)]} {
               incr NbrExamples
            }
         }
................................................................................
                  } else {
                     ProcedureHelp_Append "      $ProcDef($ProcName,-example)"
                  }
               }
            }
         }
      }
      # The created help text is by default printed to stdout.
      # The text will be returned as result when 'ReturnHelp'
      # is set to 1:
      if {$ReturnHelp} {
         return $HelpText
      } else {
         puts $HelpText
      }
   }

##########################################################################
#                        argument_dialogbox                            #
##########################################################################

   ######## Argument_dialogbox configuration ########

   # Application specific entry widget procedures can use this array
   # variable to store their own data, using as index the widget path
   # provided to the procedure, e.g. argument_dialogbox($W,<sub_index>):
   array set argument_dialogbox {}

   # Special elements of this array variable can be specified for
   # testing purposes:
   #
   # Set to following variable to "ok" to simulate an acknowledge
   # of the dialog box and to "cancel" to simulate an activation
   # of the Cancel button:
   set argument_dialogbox(test,status) ""

   # The following variable can contain a script that is executed
   # for test purposes, before the argument dialog box waits on user
   # interactions. The script is executed in the context of the
   # argument dialog box. Entire user interaction actions can be
   # emulated together with the previous variable.
   set argument_dialogbox(test,script) {}

   # The array variable 'last_parameters' is only used by an argument
   # dialog box when its context has been specified via the -context
   # attribute. The argument dialog box position and size as well as
   # its entered data are stored inside this variable when the data
   # are acknowledged and the form is closed. This allows the form
   # to restore its previous state once it is called another time.

   array set last_parameters {}


   ######## Argument_dialogbox help text ########

   set ArgumentDialogboxHelp {
      argument_dialogbox \
         [-title <DialogBoxTitle>]
         [-window <DialogBoxWindow>]
................................................................................
         [-validatecommand_error_text <Script>]
         <ArgumentDefinition>|<FrameDefinition>|<Comment>
         [<ArgumentDefinition>|<FrameDefinition>|<Separation>|<Comment>]
         [<ArgumentDefinition>|<FrameDefinition>|<Separation>|<Comment>]
         ...

      <FrameDefinition> = -frame <FrameLabel>

      <Separation> = -sep {}

      <Comment> = -comment {-text <text>}

      <ArgumentDefinition> =
         <ArgumentWidgetType>
         {
            [-variable <variable>]
            [-label <LabelName>]
................................................................................
            [-validatecommand_error_text <Script>]
            [-validatecommand2 <Script>]
            [-validatecommand2_error_text <Script>]
            [<WidgetTypeParameter1> <WidgetTypeParameterValue1>]
            [<WidgetTypeParameter2> <WidgetTypeParameterValue2>]
            ...
         }

      <ParameterWidgetType> = <StandardParameterWidgetType>|<ApplicationSpecificParameterWidgetType>

      <StandardParameterWidgetType> = {
         -entry
         -checkbox -radiobox -checkbutton
         -listbox -disjointlistbox -combobox
         -file -existingfile -directory -existingdirectory
................................................................................

   # Eliminate leading tabs in the help text and replace eventual tabs through spaces
   regsub -all -line {^\t\t} $ArgumentDialogboxHelp "" ArgumentDialogboxHelp
   regsub -all -line {\t} $ArgumentDialogboxHelp "   " ArgumentDialogboxHelp

   ######## argument_dialogbox ########

   # The argument dialog box allows a very easy generation of complex
   # dialog boxes that can be used for tool configuration purposes or
   # to control actions. This command is only available if Tk has been
   # loaded. The argument dialog box accepts only named arguments, e.g.
   # all arguments have to be defined as argument pairs
   # (-<ArgumentName> <ArgumentValue>). There are some view arguments
   # like -title, -windows, and -context that affect the argument dialog
   # box general attitude and embedding. The remaining argument block
   # objective is the definition of variables. Except the two arguments
   # -frame and -sep that are used to structure graphically the form,
   # all other arguments have to be assigned either to a local or global
   # variable. The argument dialog box will create in the procedure
   # from which it has been called a local variable, unless the variable
   # has not been defined explicitly as global variable, or as part of a
   # certain namespace.
   # The argument dialog box requires for each variable that has to be
   # controlled a separate parameter pair. The first element is indicating
   # the entry form that will be used to control the variable, the second
   # element provides information concerning the variable that has to be
   # defined and about its validation as well as parameters for the entry
   # form. TEPAM provides already a lot of available entry forms, but
   # other application specific forms can easily been added if necessary.
   # The following lines show an example of the way how the argument
   # dialog box is used:
   #
   #   argument_dialogbox \
   #      -title "System configuration" \
   #      -window .dialog_box \
   #      -context test_1 \
   #      \
   #      -frame {-label "File definitions"} \
................................................................................
   #      -frame {-label "Others"} \
   #         -color {-label "Background color" -variable MyColor} \

   proc argument_dialogbox {args} {
      variable argument_dialogbox
      variable ArgumentDialogboxHelp
      variable last_parameters

      # Generate an error if Tk hasn't been loaded
      if {[catch {package present Tk}]} {
         return -code error "argument_dialogbox requires Tk!"
      }

      # Call an initialization command that generates eventual required images:
      GuiEnvironmentInit

      #### Basic parameter check ####

         # Use the first element of args as args list if args contains
         # only one element:
         if {[llength $args] == 1} {
            set args [lindex $args 0]
         }
         # Check if arguments are provided and if the number of arguments
         # is even:
         if {[llength $args]<1} {
            return -code error "argument_dialogbox: no argument is provided"
         }
         if {[llength $args]%2 != 0 && $args ne "-help"} {
            return -code error "argument_dialogbox: arguments have to be provided in key/value pairs"
         }

      #### Global parameter evaluation and top-level window creation ####

         # The following default widget path can be changed with the
         # -window argument:
         set Wtop .dialog

         # Initialize the global parameters
         # YScroll=auto: Scroll is enabled in function of the windows
         # and screen size
         array set ProcOption {
            -validatecommand {} -validatecommand2 {}
            -validatecommand_error_text {} -validatecommand2_error_text {}
            -parent .
            -title "Dialog"
            -yscroll "auto"
         }

         # Read the global parameters by looping through all arguments
         # to select the relevant ones:
         foreach {ArgName ArgValue} $args {
            switch -- $ArgName {
               -help {puts $ArgumentDialogboxHelp; return}
               -window {set Wtop $ArgValue}
               -parent -
               -context -
               -title -
................................................................................
               -validatecommand_error_text -
               -validatecommand2_error_text {
                  lappend ProcOption($ArgName) $ArgValue
               }
            }
         }

         # Create the dialog box top-level window. Hide it until the
         # windows has been entirely deployed:
         catch {destroy $Wtop}
         toplevel $Wtop
         wm withdraw $Wtop
         wm title $Wtop $ProcOption(-title)
         wm transient $Wtop $ProcOption(-parent)

         grid [frame $Wtop.sf] -row 0 -column 0 -sticky news
         grid columnconfigure $Wtop 0 -weight 1
         grid rowconfigure $Wtop 0 -weight 1
         frame $Wtop.sf.f

         # Delete eventually variables defined by a previous call of
         # the argument dialog box:
         catch {array unset argument_dialogbox $Wtop,*}
         catch {array unset argument_dialogbox $Wtop.*}

      #### Argument dependent dialog box generation ####

         # Loop through all arguments and build the dialog box:
         set ArgNbr -1
         set Framed 0
         set W $Wtop.sf.f
         foreach {ArgName ArgValue} $args {
            incr ArgNbr

            # Check that the argument is a named argument:
            if {[string index $ArgName 0] ne "-"} {
               return -code error "Argument $ArgName not known"
            }

            # Skip the global parameters that have already been processed
            if {[lsearch -exact {
                  -window -parent -context -title -help -yscroll
                  -validatecommand -validatecommand2
                  -validatecommand_error_text -validatecommand2_error_text
               } $ArgName]>=0} continue

            # Define the widget path for the new argument:
            set WChild($ArgNbr) $W.child_$ArgNbr

            # An argument option array will be created, based on the
            # argument value list:
            if {$ArgName ne "-sep"} {
               catch  {unset Option}
               array set Option {-label "" -optional 0}
               if {[llength $ArgValue]%2 != 0} {
                  return -code error \
                     "argument_dialogbox, argument $ArgName: Attribute definition list has to contain an even number of elements"
               }
               array set Option $ArgValue
            }

            # The leading '-' of the argument name will not be used
            # anymore in the remaining code:
            set ElementType [string range $ArgName 1 end]
            switch -- $ElementType {
               frame {
                  # Handle frames - close an eventual already open frame first:
                  if {$Framed} {
                     set W [winfo parent $W]
                     set WChild($ArgNbr) $W.child_$ArgNbr
                  }
                  set Framed 0

                  # Create only a new frame when the provided argument
                  # list is not empty:
                  if {$ArgValue ne ""} {
                     # Create a labeled frame

                     pack [labelframe $WChild($ArgNbr) -bd 1 -relief solid -text $Option(-label)] \


                       -padx 6 -pady 4 -fill both -expand no




                     set W $WChild($ArgNbr)
                     set Framed 1
                  }
               }

               sep {
                  # A separator is nothing else than a frame widget
                  # that has 'no height' and a relief structure:
                  pack [frame $WChild($ArgNbr) -height 1 -bd 0 -bg black] \
                     -fill x -expand no -pady 4 -padx 2
               }

               comment {
                  # A simple label widget is used for comments:
                  pack [label $WChild($ArgNbr) -text $Option(-text) -fg blue -justify left] \
                     -anchor w -expand no -pady 2
               }

               default {
                  # All other arguments, e.g. the real entries to define
                  # the variables, are handled by procedures that provides
                  # sub commands for the different usages:
                  #   ad_form(<EntryType>) create - creates the entry widget
                  #   ad_form(<EntryType>) set_choice - set the choice constraints
                  #   ad_form(<EntryType>) set - set the default value
                  #   ad_form(<EntryType>) get - read the defined value

                  # Create a text in front of the entry widget if the
                  # -text attribute is defined:
                  if {[info exists Option(-text)]} {
                     pack [label $WChild($ArgNbr)_txt -text $Option(-text) -fg blue \
                        -justify left] -anchor w -expand no -pady 2
                  }

                  # Create for the entry a frame and place the label
                  # together with a sub frame into it:
                  pack [frame $WChild($ArgNbr)] -fill x -expand yes -padx 3
                  pack [label $WChild($ArgNbr).label -text $Option(-label)] -pady 4 -side left -padx 2
                  pack [frame $WChild($ArgNbr).f] -fill x -expand yes -side left

                  # Delete eventual existing array members related to the new entry:
                  array unset argument_dialogbox $WChild($ArgNbr),*

                  # Create the variable entry form:
                  ad_form($ElementType) $WChild($ArgNbr).f create

                  # Attribute if existing the choice list. This list
                  # can either be provided via the -choicevariable or
                  # via -choices:
                  if {[info exists Option(-choicevariable)] && \
                      [uplevel 1 "info exists \"$Option(-choicevariable)\""]} {
                     ad_form($ElementType) $WChild($ArgNbr).f set_choice \
                           [uplevel 1 "set \"$Option(-choicevariable)\""]
                  } elseif {[info exists Option(-choices)]} {
                     ad_form($ElementType) $WChild($ArgNbr).f set_choice $Option(-choices)
                  }

                  # Apply the default value. If the variable exists
                  # already, use the variable value as default value.
                  # Otherwise, check if the last_parameter array provides
                  # the value from a previous usage. And finally, check
                  # if a default value is provided via the -default option:
                  if {[info exists Option(-variable)] && \
                      [uplevel 1 "info exists \"$Option(-variable)\""]} {
                     ad_form($ElementType) $WChild($ArgNbr).f set \
                           [uplevel 1 "set \"$Option(-variable)\""]
                  } elseif {[info exists Option(-variable)] && [info exists ProcOption(-context)] && \
                            [info exists last_parameters($ProcOption(-context),$Option(-variable))]} {
                     ad_form($ElementType) $WChild($ArgNbr).f set \
                              $last_parameters($ProcOption(-context),$Option(-variable))
                  } elseif {[info exists Option(-default)]} {
                     ad_form($ElementType) $WChild($ArgNbr).f set $Option(-default)
                  }

                  # Check if the 'Validate' command is defined for the
                  # provided variable type:
                  if {[info exists Option(-type)] && [catch {Validate($Option(-type)) ""}]} {
                     return -code error \
                        "Argument_dialogbox: Argument type '$Option(-default)' not known"
                  }
               }
            }
         }

      #### Dialog box finalization ####

         # Add the OK and cancel buttons, restore eventually saved
         # geometry data and deiconify finally the form:
         grid [frame $Wtop.buttons] -row 1 -column 0 -columnspan 2 -sticky ew
         ttk::button $Wtop.buttons.ok -text OK -command "set ::tepam::argument_dialogbox($Wtop,status) ok"
         ttk::button $Wtop.buttons.cancel -text Cancel -command "set ::tepam::argument_dialogbox($Wtop,status) cancel"
         pack $Wtop.buttons.ok $Wtop.buttons.cancel -side left -fill x -expand yes -padx 4 -pady 4

         update idletasks
         if {$ProcOption(-yscroll) eq "1" || ($ProcOption(-yscroll) eq "auto" &&
                [winfo reqheight $Wtop.sf.f]+[winfo reqheight $Wtop]>[winfo screenheight $Wtop]*2/3)} {
            place $Wtop.sf.f -x 0 -y 0 -relwidth 1; # -relheight 1
            grid [ttk::scrollbar $Wtop.scale -orient v -command "tepam::argument_dialogbox_scroll $Wtop"] -row 0 -column 1 -sticky ns

            wm geometry $Wtop [winfo reqwidth $Wtop.sf.f]x[expr {[winfo screenheight $Wtop.sf.f]*2/3}]

            tepam::argument_dialogbox_scroll $Wtop init

            # Add the bindings
            bind $Wtop.sf <Configure> "tepam::argument_dialogbox_scroll $Wtop config %W %w %h"
            bind $Wtop <MouseWheel> "if {%D>0} {tepam::argument_dialogbox_scroll $Wtop scroll -1 units} elseif {%D<0} {tepam::argument_dialogbox_scroll $Wtop scroll 1 units}"
            bind $Wtop <Button-4> "tepam::argument_dialogbox_scroll $Wtop scroll -1 units"
            bind $Wtop <Button-5> "tepam::argument_dialogbox_scroll $Wtop scroll 1 units"
................................................................................
         if {[info exists ProcOption(-context)] && [info exists last_parameters($ProcOption(-context),-geometry)]} {
            ConfigureWindowsGeometry $Wtop $last_parameters($ProcOption(-context),-geometry)
         }

         wm protocol $Wtop WM_DELETE_WINDOW "set ::tepam::argument_dialogbox($Wtop,status) cancel"

         wm deiconify $Wtop

         bind $Wtop <Destroy> "set ::tepam::argument_dialogbox($Wtop,status) cancel"

      #### Wait until the dialog box entries are acknowledged (OK button) or discarded #

         # Execute a script if required (only for testing purposes)
         if {$argument_dialogbox(test,script) ne {}} {
            eval $argument_dialogbox(test,script)
         }

         # Stay in a loop until all the provided values have been validated:
         while {1} {
            # Wait until the OK or cancel button is pressed:
            set argument_dialogbox($Wtop,status) ""
            if {$argument_dialogbox(test,status) eq ""} {
               vwait ::tepam::argument_dialogbox($Wtop,status)
               set status $argument_dialogbox($Wtop,status)
            } else { # Emulate the button activation for test purposes
               set status $argument_dialogbox(test,status)
            }

            # Cancel has been pressed - exit the wait loop:
            if {$status eq "cancel"} break

            # Read all the provided values, validate them, and
            # assign them the corresponding variables:
            set ErrorMessage ""
            set ArgNbr -1
            foreach {ArgName ArgValue} $args {
               incr ArgNbr

               # Extract the element type (eliminate the
               # leading '-') and the parameters to the Option array:
               set ElementType [string range $ArgName 1 end]
               if {[llength $ArgValue]<2 || [llength $ArgValue]%2 != 0} continue
               catch  {unset Option}
               array set Option {-label "" -optional 0}
               array set Option $ArgValue
                # No variable is assigned to the entry, so skip this parameter:
               if {![info exists Option(-variable)]} continue

               # Read the result, check it and assign the result variable
               set Value [ad_form($ElementType) $WChild($ArgNbr).f get]

               # Validate the provided data:
               if {$Value ne "" || $Option(-optional) == 0} {
                  if {[info exists Option(-type)] && ![Validate($Option(-type)) $Value]} {
                     append ErrorMessage \
                        "$Option(-variable): Required type is $Option(-type)\n"
                  }
                  # Apply the validate command if existing:
                  if {[info exists Option(-validatecommand)]} {
                     regsub {%P} $Option(-validatecommand) $Value ValidateCommand
                     if {![uplevel $ValidateCommand]} {
                        if {[info exists Option(-validatecommand_error_text)]} {
                           append ErrorMessage \
                              "$Option(-validatecommand_error_text)\n"
                        } else {
                           append ErrorMessage \
                              "$Option(-variable): The value '$Value' is not valid\n"
                        }
                     }
                  }
                  # Check against a provided range:
                  if {[info exists Option(-range)]} {
                     if {$Value<[lindex $Option(-range) 0] || \
                         $Value>[lindex $Option(-range) 1]} {
                        append ErrorMessage "$Option(-variable): The value has to be between [lindex $Option(-range) 0] and [lindex $Option(-range) 1]\n"
                     }
                  }
                  # Check that the variable value is a member of a
                  # provided choice list. Some flexibility is
                  # required for this check, since the specified
                  # value may be a list of multiple elements that
                  # are matching the choice list.
                  if {[info exists Option(-choices)]} {
                     set ChoiceError 0
                     foreach v $Value {
                        if {[lsearch -exact $Option(-choices) $v]<0} {
                           incr ChoiceError
                        }
                     }
                     if {$ChoiceError && [lsearch -exact $Option(-choices) $Value]<0} {
                        append ErrorMessage \
                           "$Option(-variable): The value(s) has(have) to be one of the following elements: $Option(-choices)\n"
                     }
                  }
               }
               if {[info exists ProcOption(-context)]} {
                  set last_parameters($ProcOption(-context),$Option(-variable)) $Value
               }
            }

            if {$ErrorMessage eq ""} {
               #### Assign the values to the variables ####
               set ArgNbr -1
               foreach {ArgName ArgValue} $args {
                  incr ArgNbr
                  # Extract the element type (eliminate the
                  # leading '-') and the parameters to the Option array:
                  set ElementType [string range $ArgName 1 end]
                  if {[llength $ArgValue] < 2 || [llength $ArgValue]%2 != 0} continue
                  catch  {unset Option}
                  array set Option {-label "" -optional 0}
                  array set Option $ArgValue
                  # No variable is assigned to the entry, so skip
                  # this parameter:
                  if {![info exists Option(-variable)]} continue

                  # Read the result, check it and assign the result variable
                  set Value [ad_form($ElementType) $WChild($ArgNbr).f get]

                  # Define the variable in the context of the calling procedure:
                  if {$Value ne "" || $Option(-optional) == 0} {
                     uplevel 1 "set \"$Option(-variable)\" \{$Value\}"
                  }
               }

               #### Perform the custom argument validations ####

               foreach {VCommandO VCommandErrTxtO VLevel} {
                  -validatecommand -validatecommand_error_text 1
                  -validatecommand2 -validatecommand2_error_text 2
               } {
                  foreach ValidateCommand $ProcOption($VCommandO) ValidateCommandErrTxt $ProcOption($VCommandErrTxtO) {
                     if {![uplevel $VLevel $ValidateCommand]} {
                        if {$ValidateCommandErrTxt ne ""} {
                           append ErrorMessage "$ValidateCommandErrTxt\n"
                        } else {
                           append ErrorMessage "Validation constraint '$ArgValue' is not satisfied\n"
                        }
                     }
                  }
               }
            }

            # Exit the loop if everything could be validated
            if {$ErrorMessage eq ""} break

            # Generate otherwise an error message box
            if {$argument_dialogbox(test,status) eq ""} {
               tk_messageBox -icon error -title Error -type ok -parent $Wtop \
                             -message "The entries could not be successfully validated:\n\n$ErrorMessage\nPlease correct the related entries."
               raise $Wtop
            } else { # Return the error message as error for test purposes
               return -code error "The entries could not be successfully validated:\n\n$ErrorMessage\nPlease correct the related entries."
            }
         }

         #### Save the dialog box geometry and destroy the form ####

         if {[info exists ProcOption(-context)]} {
            if {![catch {winfo exists $Wtop} wex] && $wex} {
                set last_parameters($ProcOption(-context),-geometry) [wm geometry $Wtop]
            }
         }
         catch {destroy $Wtop}
         array unset argument_dialogbox $Wtop,*
         return $status
   }

   # The procedure 'argument_dialogbox_scroll' is used by the argument
   # dialogbox y-scrollbar to execute the scroll commands. It implements
   # the Tk typical scroll commands like 'moveto', 'scroll x pages/units'.
   # In addition to this it implements also an initialization (used to
   # initialize the scrolled frame) and a configuragion command that
   # can be executed when a configuration event happens.
   proc argument_dialogbox_scroll {Wtop Command args} {
      set FrameHeight [winfo reqheight $Wtop.sf.f]
      set VisibleHeight [expr {1.0*[winfo height $Wtop.sf]/$FrameHeight}]
      set ActualPositionY [lindex [$Wtop.scale get] 0]

      switch -- $Command {
         init {
            set ::tepam::argument_dialogbox($Wtop,wsize) ""
         }
         config {
            if {[lindex $args 0] ne "$Wtop.sf" || $args eq $::tepam::argument_dialogbox($Wtop,wsize)} return
            set ::tepam::argument_dialogbox($Wtop,wsize) $args
            argument_dialogbox_scroll $Wtop moveto 0
         }
         moveto {
            # Get the desired scroll position, and keep it within
            # the valid scroll range
            set NewPositionY [lindex $args 0]
            if {$NewPositionY<0} {set NewPositionY 0}
            if {$NewPositionY>1.0-$VisibleHeight} {set NewPositionY [expr {1.0-$VisibleHeight}]}

            # Adjust the scrollable frame location
            place configure $Wtop.sf.f -y [expr {-1.0*$NewPositionY*$FrameHeight}]

            # Adjust the scrollbar status
            $Wtop.scale set $NewPositionY [expr {$NewPositionY+$VisibleHeight}]
         }
         scroll {
            # This defines the scroll unit
            set StepH [expr {30.0/$FrameHeight}]
            switch -- $args {
               "-1 pages" {
                  argument_dialogbox_scroll $Wtop moveto [expr {$ActualPositionY-$VisibleHeight}]
               }
               "1 pages" {
                  argument_dialogbox_scroll $Wtop moveto [expr {$ActualPositionY+$VisibleHeight}]
               }
               "-1 units" {
                  argument_dialogbox_scroll $Wtop moveto [expr {$ActualPositionY-$StepH}]
               }
               "1 units" {
                  argument_dialogbox_scroll $Wtop moveto [expr {$ActualPositionY+$StepH}]
               }
            }
         }
      }
   }

   # Create the necessary resources when the argument dialog box
   # is called the first time:
   proc GuiEnvironmentInit {} {





   }

   # The following procedure defines the geometry (WxH+-X+-Y) of
   # a window. The geometry is provided as second parameter.
   # The position (X/Y) are verified and corrected if necessary to
   # make the window entirly visible on the screen.
   # This position correction is particularly interesting if an
   # application runs within the same user environment, but with
   # different screen configurations.
   proc ConfigureWindowsGeometry {W Geometry} {
      set Width 200
      set Height 150
      set whgiven [regexp {^(\d+)x(\d+)} $Geometry {} Width Height]

      set X ""
      set Y ""
      if {[regexp {([+-]+\d+)([+-]+\d+)$} $Geometry {} X Y]} {
         if {$X<0} {set X +0}
         # if {$X>[winfo screenwidth .]-[winfo reqwidth $W]} {set X +[expr {[winfo screenwidth .]-[winfo reqwidth $W]}]}
         if {$X>[winfo screenwidth .]-$Width} {set X +[expr {[winfo screenwidth .]-$Width}]}

         if {$Y<0} {set Y +0}
         # if {$Y>[winfo screenheight .]-[winfo reqheight $W]} {set Y +[expr {[winfo screenheight .]-[winfo reqheight $W]}]}
         if {$Y>[winfo screenheight .]-$Height} {set Y +[expr {[winfo screenheight .]-$Height}]}
      }

      if {$whgiven} {
         wm geometry $W ${Width}x${Height}${X}${Y}
      } else {
         wm geometry $W ${X}${Y}
      }
   }

   ######## Standard entry forms for the argument_dialogbox ########

   # A dedicated procedure that handles the geometrical aspects of
   # the argument dialog box is required for each argument type.
   # The prototype header of such a procedure is:
   #
   #    proc ad_form(<EntryType>) {W Command {Par ""}} <Body>
   #
   # The argument 'W' provides the path into which the entry has to
   # be embedded. The procedures have to provide several sub command.
   # The optional argument 'Par' is only used for the 'set' and
   # 'set_choice' sub commands:
   #
   #    ad_form(<EntryType>) <W> create
   #       This sub command has to creates the form for the given entry type.
   #
   #    ad_form(<EntryType>) <W> set_choice <ChoiceList>
   #       This sub command has to define the available selections (choice lists).
   #
................................................................................
   #          "create" {<Form creation script>}
   #          "set" {<Default value setting script>}
   #          "set_choice" {<Choice list definition script>}
   #          "get" {return [<Value evaluation script>]}
   #       }
   #    }
   #
   # The parameter definition list is mapped to the Option array
   # variable when the ad_form procedures are called. These procedures
   # can access these parameters via the Option variable of the
   # calling procedure using the upvar statement. The provided
   # frame into which each ad_form procedure can deploy the argument
   # definition entry is by default not expandable. To make them
   # expandable, for example for list boxes, the procedure
   # ad_form(make_expandable) has to be called providing it with
   # the entry path:

   proc ad_form(make_expandable) {W} {
      upvar 2 Framed Framed  FontSize FontSize
      # Override the not expanded parent frames:
      pack $W -fill both -expand yes
      pack [winfo parent $W] -fill both -expand yes
      if {$Framed} {
         # Make the parent frames expandable for that the listbox
         # can also expand
         pack [winfo parent [winfo parent [winfo parent $W]]] \
            -pady 5 -fill both -expand yes
         pack [winfo parent [winfo parent $W]] \
            -pady 5 -fill both -expand yes
      }
   }

   # Implement now all entries:

   #### Simple text entry ####

   proc ad_form(entry) {W Command {Par ""}} {
      switch $Command {
         "create" {
            pack [entry $W.entry] -fill x -expand yes -pady 4 -side left }
         "set" {
            # Clear the existing selection in case the 'set' command
            # is called multiple times
            $W.entry delete 0 end
            $W.entry insert 0 $Par
         }
         "get" {
            return [$W.entry get]
         }
      }
   }
................................................................................
   proc ad_form(text) {W Command {Par ""}} {
      # puts "ad_form(text) $W $Command $Par"
      upvar Option Option
      switch $Command {
         "create" {
            ad_form(make_expandable) $W
            grid [text $W.text -yscrollcommand "$W.yscrollbar set"] -column 0 -row 0 -pady 2 -sticky news
            grid [ttk::scrollbar $W.yscrollbar -command "$W.text yview"] -column 1 -row 0 -pady 2 -sticky ns

            # Add a horizontal scroll bar if wrapping is disabled
            if {[info exists Option(-wrap)] && $Option(-wrap) eq "none"} {
               grid [ttk::scrollbar $W.xscrollbar -command "$W.text xview" -orient horizontal] -column 0 -row 1 -sticky ew
               $W.text config -xscrollcommand "$W.xscrollbar set"
            }
            grid columnconfigure $W 0 -weight 1
            grid rowconfigure $W 0 -weight 1

            # Apply the text widget parameters
            $W.text config -wrap word -height 4; # Default parameters
            foreach Par {-height -wrap} {
               if {[info exists Option($Par)]} {
                  $W.text config $Par $Option($Par)
               }
            }
................................................................................
            return [$W.text get 0.0 "end - 1 chars"]
         }
      }
   }

   #### Color entry ####

   # Select_color sets the text and color of the color entry to a new color:
   proc select_color {W NewColor} {
      if {$NewColor ne ""} {
         $W.entry delete 0 end
         $W.entry insert 0 $NewColor
      }
      $W.entry config -background gray80
      catch {$W.entry config -background [$W.entry get]}
   }

................................................................................
         set Option(-type) color
      }
      set Title ""
      catch {set Title $Option(-label)}
      switch $Command {
         "create" {
            pack [entry $W.entry] -fill x -expand yes -pady 4 -side left
            pack [ttk::button $W.button -text "Choose" -command "::tepam::select_color $W \[tk_chooseColor -parent \{$W\} -title \{$Title\}\]"] \
                -padx 3 -pady 4 -side left
            bind $W.entry <Key-Return> "tepam::select_color $W {}"
            bind $W.entry <Leave> "tepam::select_color $W {}"
         }
         "set" {
            select_color $W $Par
         }
         "get" {
................................................................................
      }
   }

   #### File and directory entries ####

   # Select_file sets the file or directory entry to a new file name:
   proc select_file {W NewFile} {
      if {$NewFile eq ""} return
      $W.entry delete 0 end
      $W.entry insert 0 $NewFile
   }

   # Ad_form(directory_or_file) is a generic implementation of a file
   # and directory selection form. It will be used for the different
   # file and directory types:
   proc ad_form(directory_or_file) {W Type Command {Par ""}} {
      upvar 2 Option Option
      if {![info exists Option(-type)]} {
         set Option(-type) $Type
      }
      set Title ""
      catch {set Title $Option(-label)}
................................................................................
            set InitialFile "\[$W.entry get\]";
            if {[info exists Option(-initialfile)]} {
               set InitialFile $Option(-initialfile)
               set ActiveDir [file dirname $Option(-initialfile)]
            }

            pack [entry $W.entry] -fill x -expand yes -pady 4 -side left
            if {$Type eq "existingdirectory"} {
               pack [ttk::button $W.button -text Browse -command "::tepam::select_file $W \[tk_chooseDirectory -parent $W -initialdir \"$ActiveDir\" -title \{$Title\}\]"] -padx 3 -pady 4 -side left
            } elseif {$Type eq "directory"} {
               pack [ttk::button $W.button -text Browse -command "::tepam::select_file $W \[tk_chooseDirectory -parent $W -initialdir \"$ActiveDir\" -title \{$Title\}\]"] -padx 3 -pady 4 -side left
            } elseif {$Type eq "existingfile"} {
               pack [ttk::button $W.button -text Browse -command "::tepam::select_file $W \[tk_getOpenFile   -parent $W -filetypes \{$FileTypes\} -initialdir \"$ActiveDir\" -initialfile \"$InitialFile\" -title \{$Title\}\]"] -padx 3 -pady 4 -side left
            } else {
               # file
               pack [ttk::button $W.button -text Browse -command "::tepam::select_file $W \[tk_getSaveFile  -parent $W -filetypes \{$FileTypes\} -initialdir \"$ActiveDir\" -initialfile \"$InitialFile\" -title \{$Title\}\]"] -padx 3 -pady 4 -side left
            }
         }
         "set" {
            $W.entry delete 0 end; # Clear the existing selection in case the 'set' command is called multiple times
            $W.entry insert 0 $Par
         }
         "get" {
            return [$W.entry get]
         }
      }
   }

   # The generic file and directory selection command
   # 'ad_form(directory_or_file)' are used to implement the 4 file
   # and directory selection forms:

   proc ad_form(directory) {W Command {Par ""}} {
      ad_form(directory_or_file) $W directory $Command $Par
   }

   proc ad_form(existingdirectory) {W Command {Par ""}} {
      ad_form(directory_or_file) $W existingdirectory $Command $Par
................................................................................
   }

   #### Combobox ####

   proc ad_form(combobox) {W Command {Par ""}} {
      switch $Command {
         "create" {
            pack [entry $W.entry] -fill x -expand yes -pady 4 -side left
            pack [button $W.button -relief flat -borderwidth 0 -padx 2 -pady 0 -justify left -text "\u25be" -command "tepam::ad_form(combobox) $W open_selection"] -pady 4 -side left

            toplevel $W.selection -border 1 -background black
            if {[tk windowingsystem] eq "x11"} {
               wm attributes $W.selection -type popup_menu
               if {[info command sdltk] eq "sdltk"} {
                  wm overrideredirect $W.selection 1
               }
            } else {
               wm overrideredirect $W.selection 1
            }
            wm withdraw $W.selection
            pack [listbox $W.selection.listbox -yscrollcommand "$W.selection.scrollbar set" -exportselection 0 -selectmode single] -fill both -expand yes -side left
            pack [ttk::scrollbar $W.selection.scrollbar -command "$W.selection.listbox yview"] -fill y -side left -expand no

            bind $W.selection.listbox <<ListboxSelect>> "tepam::ad_form(combobox) $W close_selection"
            bind $W.selection <FocusOut> "tepam::ad_form(combobox) $W cancel_selection"
            bind $W.selection <Escape> "tepam::ad_form(combobox) $W cancel_selection"
            bind $W.selection <1> "tepam::ad_form(combobox) $W button_press {%X %Y}"
         }
         "set" {
            $W.entry delete 0 end; # Clear the existing selection in case the 'set' command is called multiple times
            $W.entry insert 0 $Par
         }
         "get" {
            return [$W.entry get]
................................................................................
         }
         "set_choice" {
            foreach v $Par {
               $W.selection.listbox insert end $v
            }
         }
         "open_selection" {
            ConfigureWindowsGeometry $W.selection [expr {[winfo width $W.entry]+[winfo width $W.button]}]x100+[winfo rootx $W.entry]+[expr {[winfo rooty $W.entry]+[winfo height $W.entry]}]

            catch {$W.selection.listbox selection clear 0 end}
            catch {$W.selection.listbox selection set [lsearch -exact [$W.selection.listbox get 0 end] [$W.entry get]]}
            catch {$W.selection.listbox yview [lsearch -exact [$W.selection.listbox get 0 end] [$W.entry get]]}

            wm deiconify $W.selection
	    grab $W.selection
            focus $W.selection.listbox
         }
         "close_selection" {
            $W.entry delete 0 end
            $W.entry insert 0 [$W.selection.listbox get [$W.selection.listbox curselection]]
	    grab release $W.selection
            wm withdraw $W.selection
         }
         "cancel_selection" {
	    grab release $W.selection
            wm withdraw $W.selection
         }
         "button_press" {
            if {[winfo containing -displayof $W {*}$Par] ne "$W.selection"} {
	       grab release $W.selection
               wm withdraw $W.selection
               return -code break
            }
         }
      }
   }

   #### Listbox ####

   proc ad_form(listbox) {W Command {Par ""}} {
      # puts "ad_form(listbox) $W $Command $Par"
................................................................................
      switch $Command {
         "create" {
            ad_form(make_expandable) $W
            pack [listbox $W.listbox -yscrollcommand "$W.scrollbar set" -exportselection 0] -fill both -expand yes -pady 4 -side left
            if {[info exists Option(-multiple_selection)] && $Option(-multiple_selection)} {
               $W.listbox config -selectmode extended
            }
            pack [ttk::scrollbar $W.scrollbar -command "$W.listbox yview"] -fill y -pady 4 -side left -expand no
            if {[info exists Option(-height)]} {
               $W.listbox config -height $Option(-height)
            }
         }
         "set" {
            catch {$W.listbox selection clear 0 end}; # Clear the existing selection in case the 'set' command is called multiple times
            if {[info exists Option(-multiple_selection)] && $Option(-multiple_selection)} {
................................................................................
   #### Disjoint listbox ####

   proc disjointlistbox_move {W Move} {
      switch $Move {
         "add" {
            $W.listbox2 selection clear 0 end
            foreach o [lsort -integer -increasing [$W.listbox1 curselection]] {
               if {[$W.listbox1 itemcget $o -foreground] eq "grey"} continue
               $W.listbox2 insert end [$W.listbox1 get $o]
               $W.listbox2 selection set end
               $W.listbox1 itemconfigure $o -foreground grey
            }
            $W.listbox1 selection clear 0 end
         }
         "delete" {
            foreach o [lsort -integer -decreasing [$W.listbox2 curselection]] {
               for {set o1 0} {$o1<[$W.listbox1 index end]} {incr o1} {
                  if {[$W.listbox2 get $o] eq [$W.listbox1 get $o1]} {
                     $W.listbox1 itemconfigure $o1 -foreground ""
                  }
               }
               $W.listbox2 delete $o
            }
         }
         "up" {
            foreach o [$W.listbox2 curselection] {
               if {$o == 0} continue
               $W.listbox2 insert [expr {$o-1}] [$W.listbox2 get $o]
               $W.listbox2 delete [expr {$o+1}]
               $W.listbox2 selection set [expr {$o-1}]
            }
         }
         "down" {
            foreach o [lsort -integer -decreasing [$W.listbox2 curselection]] {
               if {$o == [$W.listbox2 index end] - 1} continue
               $W.listbox2 insert [expr {$o+2}] [$W.listbox2 get $o]
               $W.listbox2 delete $o
               $W.listbox2 selection set [expr {$o+1}]
            }
         }
      }
   }

   proc ad_form(disjointlistbox) {W Command {Par ""}} {
      # puts "ad_form(listbox) $W $Command $Par"
................................................................................
         "create" {
            ad_form(make_expandable) $W

            grid [label $W.label1 -text "Available"] -column 1 -row 0 -sticky ew
            grid [label $W.label2 -text "Selected"] -column 3 -row 0 -sticky ew

            grid [listbox $W.listbox1 -yscrollcommand "$W.scrollbar1 set" -exportselection 0 -selectmode extended] -column 1 -row 1 -rowspan 2 -sticky news
            grid [ttk::scrollbar $W.scrollbar1 -command "$W.listbox1 yview"] -column 2 -row 1 -rowspan 2 -sticky ns
            grid [listbox $W.listbox2 -yscrollcommand "$W.scrollbar2 set" -exportselection 0 -selectmode extended] -column 3 -row 1 -rowspan 2 -sticky news
            grid [ttk::scrollbar $W.scrollbar2 -command "$W.listbox2 yview"] -column 4 -row 1 -rowspan 2 -sticky ns

            grid [ttk::button $W.up -text "\u25b2" -command "::tepam::disjointlistbox_move $W up"] -column 5 -row 1 -sticky news -padx 3 -pady 3
            grid [ttk::button $W.down -text "\u25bc" -command "::tepam::disjointlistbox_move $W down"] -column 5 -row 2 -sticky news -padx 3 -pady 3

            grid [ttk::button $W.add -text "\u25ba" -command "::tepam::disjointlistbox_move $W add"] -column 1 -row 3 -columnspan 2 -sticky news -padx 1 -pady 3
            grid [ttk::button $W.remove -text "\u25c4" -command "::tepam::disjointlistbox_move $W delete"] -column 3 -row 3 -columnspan 2 -sticky news -padx 1 -pady 3

            foreach {Col Weight} {0 0  1 1   2 0   3 1   4 0   5 0} {
               grid columnconfigure $W $Col -weight $Weight
             }
            grid rowconfigure $W 1 -weight 1
            grid rowconfigure $W 2 -weight 1
            if {[info exists Option(-height)]} {
................................................................................
               $W.listbox2 config -height $Option(-height)
            }
         }
         "set" {
            # Delete an eventually previous selection (this should not be required by argument_dialogox)
            $W.listbox2 selection set 0 end
            disjointlistbox_move $W delete

            foreach o $Par {
               set p [lsearch -exact [$W.listbox1 get 0 end] $o]
               if {$p>=0} { # Delete the selected item from the available items
                  $W.listbox1 selection set $p
                  disjointlistbox_move $W add
               }
            }
................................................................................
            set argument_dialogbox($W,ButtonsW) {}
         }
         "set" {
            # Delete an eventually previous selection
            foreach ChoiceIndex [array names argument_dialogbox $W,values,*] {
               set argument_dialogbox($ChoiceIndex) ""
            }
            # Select the check buttons that correspond to the provided values
            foreach v $Par {
               foreach BW $argument_dialogbox($W,ButtonsW) {
                  if {$v eq [$BW cget -onvalue]} {
                     set [$BW cget -variable] $v
                  }
               }
            }
         }
         "get" {
            # Provide the selected items in the order of the provided
            # choice list
            set Result {}
            foreach ChoiceIndex \
               [lsort -dictionary [array names argument_dialogbox $W,values,*]] {
               if {$argument_dialogbox($ChoiceIndex) ne ""} {
                  lappend Result $argument_dialogbox($ChoiceIndex) }
               }
            return $Result
         }
         "set_choice" {
            set ChoiceNumber 0
            set PackSide left
            if {[info exists Option(-direction)] && $Option(-direction) eq "vertical"} {
               set PackSide top
            }
            foreach v $Par {
               set label $v
               catch {set label [lindex $Option(-choicelabels) $ChoiceNumber]}
               pack [ttk::checkbutton $W.choice_$ChoiceNumber -text $label -variable ::tepam::argument_dialogbox($W,values,$ChoiceNumber) -onvalue $v -offvalue ""] -side $PackSide -anchor w -padx 2
               lappend argument_dialogbox($W,ButtonsW) $W.choice_$ChoiceNumber
               incr ChoiceNumber
            }
         }
      }
   }

................................................................................
         "get" {
            return $argument_dialogbox($W,values)
         }
         "set_choice" {
            set argument_dialogbox($W,values) [lindex [lindex $Par 0] 0]
            set ChoiceNumber 0
            set PackSide left
            if {[info exists Option(-direction)] && $Option(-direction) eq"vertical"} {
               set PackSide top
            }
            foreach v $Par {
               set label $v
               catch {set label [lindex $Option(-choicelabels) $ChoiceNumber]}
               pack [ttk::radiobutton $W.choice_$ChoiceNumber -text $label -variable ::tepam::argument_dialogbox($W,values) -value $v] -side $PackSide -anchor w -padx 2
               incr ChoiceNumber
            }
         }
      }
   }

   #### Checkbutton ####

   proc ad_form(checkbutton) {W Command {Par ""}} {
      variable argument_dialogbox
      switch $Command {
         "create" {
            pack [ttk::checkbutton $W.checkb -variable ::tepam::argument_dialogbox($W,values)] -pady 4 -side left -padx 2
            set argument_dialogbox($W,values) 0
         }
         "set" {
            set argument_dialogbox($W,values) $Par
         }
         "get" {
            return $argument_dialogbox($W,values)
................................................................................
      regexp {^\.*(\..*)$} $parent.font_selection {} W
      catch {destroy $W}
      toplevel $W
      wm withdraw $W
      wm transient $W $parent
      wm group $W $parent
      wm title $W $title
      update idletasks

      pack [label $W.into -text "Please choose a font and its size \nand style, then select OK." -justify left] -expand no -fill x

      pack [frame $W.sels] -expand yes -fill both -padx 4
      pack [listbox $W.sels.lb_font -yscrollcommand "$W.sels.sb_font set" -exportselection 0 -height 10] -side left -expand yes -fill both
      bind $W.sels.lb_font <<ListboxSelect>> "::tepam::ChooseFont_Update $W"
      pack [ttk::scrollbar $W.sels.sb_font -command "$W.sels.lb_font yview"] -side left -expand no -fill both
      pack [listbox $W.sels.lb_size -yscrollcommand "$W.sels.sb_size set" -width 3 -exportselection 0 -height 10] -side left -expand no -fill both
      bind $W.sels.lb_size <<ListboxSelect>> "::tepam::ChooseFont_Update $W"
      pack [ttk::scrollbar $W.sels.sb_size -command "$W.sels.lb_size yview"] -side left -expand no -fill both

      set ButtonFont [font actual [[button $W.dummy] cget -font]]
      pack [frame $W.styles] -expand no -fill x -padx 4 -pady 4
      pack [checkbutton $W.styles.bold -text B -indicatoron off -font "$ButtonFont -weight bold" -variable ::tepam::ChooseFont($W,bold) -command "::tepam::ChooseFont_Update $W"] -side left -expand yes -fill x
      pack [checkbutton $W.styles.italic -text I -indicatoron off -font "$ButtonFont -slant italic" -variable ::tepam::ChooseFont($W,italic) -command "::tepam::ChooseFont_Update $W"] -side left -expand yes -fill x
      pack [checkbutton $W.styles.underline -text U -indicatoron off -font "$ButtonFont -underline 1" -variable ::tepam::ChooseFont($W,underline) -command "::tepam::ChooseFont_Update $W"] -side left -expand yes -fill x
      pack [checkbutton $W.styles.overstrike -text O -indicatoron off -font "$ButtonFont -overstrike 1" -variable ::tepam::ChooseFont($W,overstrike) -command "::tepam::ChooseFont_Update $W"] -side left -expand yes -fill x

      pack [label $W.text -text "Test text 1234"] -expand no -fill x

      pack [frame $W.buttons] -expand no -fill x
      pack [ttk::button $W.buttons.ok -text OK -command "set ::tepam::ChooseFont($W,status) 0"] -side left -expand yes -fill x -padx 4 -pady 4
      pack [ttk::button $W.buttons.cancel -text Cancel -command "set ::tepam::ChooseFont($W,status) 3"] -side left -expand yes -fill x -padx 4 -pady 4

      # Create the font size and family lists. Use default lists when no family or sizes
      # are provided.
      if {$font_families eq {}} {
         set font_families [font families]
      }
      foreach v $font_families {
         $W.sels.lb_font insert end $v
      }

      if {$font_sizes eq {}} {
         set font_sizes {6 7 8 9 10 12 14 16 18 20 24 28 32 36 40}
      }
      foreach v $font_sizes {
         $W.sels.lb_size insert end $v
      }

      # Set the default font selection
      if {![info exists default]} {
         set default [$W.text cget -font]
         # puts "default:$default"
      }

      set Index [lsearch -exact $font_families [lindex $default 0]]
      if {$Index<0} {set Index [lsearch -exact $font_families [font actual $default -family]]}
      if {$Index<0} {set Index 0}
      # puts "[font actual $default -family] -> $Index"
      $W.sels.lb_font selection clear 0 end
      $W.sels.lb_font selection set $Index
      $W.sels.lb_font yview $Index
................................................................................
      foreach Style [lrange $default 2 end] {
         if {[info exists ::tepam::ChooseFont($W,$Style)]} {
            set ::tepam::ChooseFont($W,$Style) 1
         }
      }

      wm protocol $W WM_DELETE_WINDOW "set ::tepam::ChooseFont($W,status) 3"
      ::tk::PlaceWindow $W widget $parent


      # Wait until the OK or cancel button is pressed:
      set ::tepam::ChooseFont($W,status) ""
      set oldGrab [grab current $W]
      set oldStatus ""
      if {[winfo exists $oldGrab]} {
         set oldStatus [grab status $oldGrab]
      }
      catch {grab $W}
      vwait ::tepam::ChooseFont($W,status)
      grab release $W

      set SelectedFont [ChooseFont_Get $W]
      destroy $W
      if {[winfo exists $oldGrab] && [winfo ismapped $oldGrab]} {
         if {$oldStatus eq "global"} {
            grab -global $oldGrab
         } else {
            grab $old
         }
      }
      if {$::tepam::ChooseFont($W,status) == 0} {return $SelectedFont}
      return ""
   }

   # Select_font sets the text and the font of the font entry to a font color:
   proc select_font {W NewFont} {
      variable argument_dialogbox
      if {$NewFont ne ""} {
         $W.entry delete 0 end
         $W.entry insert 0 $NewFont
      }
      $W.entry config -bg gray80
      catch {
         $W.entry config -font [$W.entry get]
         $W.entry config -bg $argument_dialogbox($W,DefaultEntryColor)
................................................................................
      set Title ""
      catch {set Title $Option(-label)}
      switch $Command {
         "create" {
            # The dedicated attributes -font_families and -font_sizes by this entry widget:
            set FamilyList [font families]
            catch {set FamilyList $Option(-font_families)}

            set SizeList {6 7 8 9 10 12 14 16 18 20 24 28 32 36 40}
            catch {set SizeList $Option(-font_sizes)}

            # Create the entry widget
            pack [entry $W.entry] -fill x -expand yes -pady 4 -side left
            pack [ttk::button $W.button -text "Choose" \
                -command "::tepam::select_font $W \[::tepam::ChooseFont -parent \{$W\} -title \{$Title\} -font_families \{$FamilyList\} -font_sizes \{$SizeList\} -default \[$W.entry get\]\]"] \
                -padx 3 -pady 4 -side left
            bind $W.entry <Key-Return> "tepam::select_font $W {}"
            bind $W.entry <Leave> "tepam::select_font $W {}"

            set argument_dialogbox($W,DefaultEntryColor) [$W.entry cget -bg]

            # Use the default font of the entry widget as default font selection if its font
            # family and font size is part of the selection lists. Use otherwise the first
            # elements of the family list and the closest size for the default font.
            set DefaultFont [$W.entry cget -font]

            set DefaultFamily [font actual $DefaultFont -family]
            if {[lsearch -exact $FamilyList $DefaultFamily]<0} {
               set DefaultFamily [lindex $FamilyList 0]
            }

            set DefaultSize [font actual $DefaultFont -size]
            if {[lsearch -exact $SizeList $DefaultSize]<0} {
               set SizeList [lsort -real [concat $SizeList $DefaultSize]]
               set Pos [lsearch -exact $SizeList $DefaultSize]
               if {$Pos == 0} {
                 set DefaultSize [lindex $SizeList 1]
               } elseif {$Pos == [llength $SizeList] - 1} {
                 set DefaultSize [lindex $SizeList end-1]
               } elseif {[lindex $SizeList $Pos]-[lindex $SizeList [expr {$Pos-1}]] <
                         [lindex $SizeList [expr {$Pos+1}]]-[lindex $SizeList $Pos] } {
                 set DefaultSize [lindex $SizeList [expr {$Pos-1}]]
               } else {
                 set DefaultSize [lindex $SizeList [expr {$Pos+1}]]
               }
            }

            select_font $W [list $DefaultFamily $DefaultSize]
         }
         "set" {
            select_font $W $Par
................................................................................

##########################################################################
# Id: tepam.tcl
# Modifications:
#
# TEPAM version 0.5.1 - 2016/03/05 droll
# * Help generation
#   - Correction of bug a0e091b25d (Misformatted description in auto-generated
#     help text)
#
# TEPAM version 0.5 - 2013/10/14 droll
# * procedure command
#   - New procedure attributes: -validatecommand_error_text, -validatecommand
#   - Updated argument attribute: -validatecommand (the command is now
#     executed in the context of the procedure body which allows accessing
#     argument variables)
#   - New argument attribute: -validatecommand_error_text
#   - Minor bug fix: The TEPAM internal procedure list was incorrect if a
#     procedure was defined multiple times.
#   - Procedure help generation: Indicate if an argument can be used multiple
#     times
# * argument_dialogbox
#   - New global attributes: -validatecommand_error_text, -validatecommand
#   - New argument attributes: -validatecommand_error_text, -validatecommand,
#                              -validatecommand_error_text2, -validatecommand2
#
# TEPAM version 0.4.1 - 2013/03/25 droll
# * Correction of bug 3608952: Help text is incorrectly generated if procedures
#   are part of the non-default namespaces
# * Correction of bug 3608951: Help text shows incorrect argument order if
#   procedure is defined in the "unnamed arguments first, named arguments later"
#    calling style.
#
# TEPAM version 0.4.0 - 2012/05/07 20:24:58  droll
# * Add the new text procedure argument type and the text multi line data
#   entry widget.
#
# TEPAM version 0.3.0 - 2012/03/26 20:44:10  droll

Changes to jni/SDL2/src/core/linux/SDL_evdev_kbd.c.

193
194
195
196
197
198
199
200
201
202
203
204
205
206
207

SDL_EVDEV_keyboard_state *
SDL_EVDEV_kbd_init(void)
{
    SDL_EVDEV_keyboard_state *kbd;
    int i;
    char flag_state;
    char shift_state[2] = {TIOCL_GETSHIFTSTATE, 0};

    kbd = (SDL_EVDEV_keyboard_state *)SDL_calloc(1, sizeof(*kbd));
    if (!kbd) {
        return NULL;
    }

    kbd->npadch = -1;







|







193
194
195
196
197
198
199
200
201
202
203
204
205
206
207

SDL_EVDEV_keyboard_state *
SDL_EVDEV_kbd_init(void)
{
    SDL_EVDEV_keyboard_state *kbd;
    int i;
    char flag_state;
    char shift_state[ sizeof (long) ] = {TIOCL_GETSHIFTSTATE, 0};

    kbd = (SDL_EVDEV_keyboard_state *)SDL_calloc(1, sizeof(*kbd));
    if (!kbd) {
        return NULL;
    }

    kbd->npadch = -1;

Changes to jni/SDL2/src/events/SDL_mouse.c.

582
583
584
585
586
587
588

589
590
591
592
593
594
595
    cursor = mouse->cursors;
    while (cursor) {
        next = cursor->next;
        SDL_FreeCursor(cursor);
        cursor = next;
    }
    mouse->cursors = NULL;


    if (mouse->def_cursor && mouse->FreeCursor) {
        mouse->FreeCursor(mouse->def_cursor);
        mouse->def_cursor = NULL;
    }

    if (mouse->clickstate) {







>







582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
    cursor = mouse->cursors;
    while (cursor) {
        next = cursor->next;
        SDL_FreeCursor(cursor);
        cursor = next;
    }
    mouse->cursors = NULL;
    mouse->cur_cursor = NULL;

    if (mouse->def_cursor && mouse->FreeCursor) {
        mouse->FreeCursor(mouse->def_cursor);
        mouse->def_cursor = NULL;
    }

    if (mouse->clickstate) {

Changes to jni/SDL2/src/video/kmsdrm/SDL_kmsdrmvideo.c.

402
403
404
405
406
407
408





409
410
411
412
413
414
415
...
466
467
468
469
470
471
472










473
474
475
476
477
478
479

#ifdef SDL_INPUT_LINUXEV
    SDL_EVDEV_Init();
#endif

    KMSDRM_InitMouse(_this);






cleanup:
    if (encoder != NULL)
        KMSDRM_drmModeFreeEncoder(encoder);
    if (connector != NULL)
        KMSDRM_drmModeFreeConnector(connector);
    if (resources != NULL)
        KMSDRM_drmModeFreeResources(resources);
................................................................................
        close(vdata->drm_fd);
        SDL_LogDebug(SDL_LOG_CATEGORY_VIDEO, "Closed DRM FD %d", vdata->drm_fd);
        vdata->drm_fd = -1;
    }
#ifdef SDL_INPUT_LINUXEV
    SDL_EVDEV_Quit();
#endif










}

void
KMSDRM_GetDisplayModes(_THIS, SDL_VideoDisplay * display)
{
    /* Only one display mode available, the current one */
    SDL_AddDisplayMode(display, &display->current_mode);







>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>







402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
...
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494

#ifdef SDL_INPUT_LINUXEV
    SDL_EVDEV_Init();
#endif

    KMSDRM_InitMouse(_this);

    vdata->resources = resources;
    vdata->connector = connector;
    vdata->encoder = encoder;
    return ret;

cleanup:
    if (encoder != NULL)
        KMSDRM_drmModeFreeEncoder(encoder);
    if (connector != NULL)
        KMSDRM_drmModeFreeConnector(connector);
    if (resources != NULL)
        KMSDRM_drmModeFreeResources(resources);
................................................................................
        close(vdata->drm_fd);
        SDL_LogDebug(SDL_LOG_CATEGORY_VIDEO, "Closed DRM FD %d", vdata->drm_fd);
        vdata->drm_fd = -1;
    }
#ifdef SDL_INPUT_LINUXEV
    SDL_EVDEV_Quit();
#endif

    if (vdata->encoder != NULL)
        KMSDRM_drmModeFreeEncoder(vdata->encoder);
    vdata->encoder = NULL;
    if (vdata->connector != NULL)
        KMSDRM_drmModeFreeConnector(vdata->connector);
    vdata->connector = NULL;
    if (vdata->resources != NULL)
        KMSDRM_drmModeFreeResources(vdata->resources);
    vdata->resources = NULL;
}

void
KMSDRM_GetDisplayModes(_THIS, SDL_VideoDisplay * display)
{
    /* Only one display mode available, the current one */
    SDL_AddDisplayMode(display, &display->current_mode);

Changes to jni/SDL2/src/video/kmsdrm/SDL_kmsdrmvideo.h.

42
43
44
45
46
47
48



49
50
51
52
53
54
55
    int drm_fd;                 /* DRM file desc */
    struct gbm_device *gbm;
    drmEventContext drm_evctx;  /* DRM event context */
    struct pollfd drm_pollfd;   /* pollfd containing DRM file desc */
    drmModeCrtc *saved_crtc;    /* Saved CRTC to restore on quit */
    uint32_t saved_conn_id;     /* Saved DRM connector ID */
    uint32_t crtc_id;           /* CRTC in use */



} SDL_VideoData;


typedef struct SDL_DisplayData
{
    uint32_t encoder_id;
    uint32_t crtc_id;







>
>
>







42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
    int drm_fd;                 /* DRM file desc */
    struct gbm_device *gbm;
    drmEventContext drm_evctx;  /* DRM event context */
    struct pollfd drm_pollfd;   /* pollfd containing DRM file desc */
    drmModeCrtc *saved_crtc;    /* Saved CRTC to restore on quit */
    uint32_t saved_conn_id;     /* Saved DRM connector ID */
    uint32_t crtc_id;           /* CRTC in use */
    drmModeRes *resources;
    drmModeConnector *connector;
    drmModeEncoder *encoder;
} SDL_VideoData;


typedef struct SDL_DisplayData
{
    uint32_t encoder_id;
    uint32_t crtc_id;

Changes to jni/sdl2tk/sdl/SdlTkGfx.c.

652
653
654
655
656
657
658



659
660
661
662
663
664
665
SdlTkGfxExposeRegion(Window w, Region dirtyRgn)
{
    long i;
    int count;

    if (!(((_Window *) w)->atts.your_event_mask & ExposureMask)) {
	return 0;



    }
    if (XEmptyRegion(dirtyRgn)) {
	return 0;
    }
    count = dirtyRgn->numRects - 1;
    for (i = 0; i < dirtyRgn->numRects; i++, count--) {
	BoxPtr box = &((REGION *) dirtyRgn)->rects[i];







>
>
>







652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
SdlTkGfxExposeRegion(Window w, Region dirtyRgn)
{
    long i;
    int count;

    if (!(((_Window *) w)->atts.your_event_mask & ExposureMask)) {
	return 0;
    }
    if (((_Window *) w)->clazz == InputOnly) {
	return 0;
    }
    if (XEmptyRegion(dirtyRgn)) {
	return 0;
    }
    count = dirtyRgn->numRects - 1;
    for (i = 0; i < dirtyRgn->numRects; i++, count--) {
	BoxPtr box = &((REGION *) dirtyRgn)->rects[i];

Changes to jni/sdl2tk/sdl/SdlTkInt.c.

2578
2579
2580
2581
2582
2583
2584

2585
2586
2587
2588
2589
2590
2591
....
2615
2616
2617
2618
2619
2620
2621
2622

2623
2624
2625
2626
2627
2628
2629
	 */
	if (parent->child != _w) {
	    Region rgn2 = SdlTkRgnPoolGet();

	    child = parent->child;
	    while (child != _w) {
		if ((child->atts.map_state != IsUnmapped) &&

		    (XRectInRegion(_w->visRgnInParent, child->atts.x,
				   child->atts.y, child->parentWidth,
				   child->parentHeight) != RectangleOut)) {
		    rect.x = child->atts.x;
		    rect.y = child->atts.y;
		    rect.width = child->parentWidth;
		    rect.height = child->parentHeight;
................................................................................
     * Subtract one rectangle for each mapped child from visRgn (a window
     * can't draw over its children)
     */
    if (_w->child != NULL) {
	Region rgn2 = SdlTkRgnPoolGet();

	for (child = _w->child; child != NULL; child = child->next) {
	    if (child->atts.map_state != IsUnmapped) {

		rect.x = _w->atts.x + child->atts.x;
		rect.y = _w->atts.y + child->atts.y;
		rect.width = child->parentWidth;
		rect.height = child->parentHeight;
		XUnionRectWithRegion(&rect, rgn2, rgn2);
	    }
	}







>







 







|
>







2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
....
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
	 */
	if (parent->child != _w) {
	    Region rgn2 = SdlTkRgnPoolGet();

	    child = parent->child;
	    while (child != _w) {
		if ((child->atts.map_state != IsUnmapped) &&
		    (child->clazz != InputOnly) &&
		    (XRectInRegion(_w->visRgnInParent, child->atts.x,
				   child->atts.y, child->parentWidth,
				   child->parentHeight) != RectangleOut)) {
		    rect.x = child->atts.x;
		    rect.y = child->atts.y;
		    rect.width = child->parentWidth;
		    rect.height = child->parentHeight;
................................................................................
     * Subtract one rectangle for each mapped child from visRgn (a window
     * can't draw over its children)
     */
    if (_w->child != NULL) {
	Region rgn2 = SdlTkRgnPoolGet();

	for (child = _w->child; child != NULL; child = child->next) {
	    if ((child->atts.map_state != IsUnmapped) &&
		(child->clazz != InputOnly)) {
		rect.x = _w->atts.x + child->atts.x;
		rect.y = _w->atts.y + child->atts.y;
		rect.width = child->parentWidth;
		rect.height = child->parentHeight;
		XUnionRectWithRegion(&rect, rgn2, rgn2);
	    }
	}

Changes to jni/sdl2tk/sdl/SdlTkX.c.

49
50
51
52
53
54
55


56
57
58
59
60
61
62
....
5436
5437
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
5450
....
5545
5546
5547
5548
5549
5550
5551



5552
5553
5554
5555
5556
5557
5558
....
5605
5606
5607
5608
5609
5610
5611



5612
5613
5614
5615
5616
5617
5618
....
6583
6584
6585
6586
6587
6588
6589


6590






6591


6592
6593
6594
6595
6596
6597
6598

#ifdef AGG_CUSTOM_ALLOCATOR
/* AGG custom allocator functions */
void *(*agg_custom_alloc)(unsigned int size) = NULL;
void (*agg_custom_free)(void *ptr) = NULL;
#endif



TCL_DECLARE_MUTEX(atom_mutex);
static int atom_initialized = 0;
static Tcl_HashTable atom_table;
static int prop_initialized = 0;
static Tcl_HashTable prop_table;

struct RootSizeRequest {
................................................................................
    SDL_PixelFormat *pfmt;
    int xdpi, ydpi;
    int initMask = SDL_INIT_VIDEO | SDL_INIT_JOYSTICK;
#ifndef ANDROID
    int tfmt = SDL_PIXELFORMAT_RGB888;
#endif
#ifdef linux
    int setQuit = 0, checkInput = 0;
    char *p;
#elif defined(__APPLE__) || defined(_WIN32)
    char *p;
#endif
    XGCValues values;

#ifdef AGG_CUSTOM_ALLOCATOR
................................................................................
	setQuit = 1;
	checkInput = 1;
	/*
	 * -sdlfullscreen with RPI driver doesn't work.
	 */
	SdlTkX.arg_fullscreen = 0;
    } else if (strcmp(p, "KMSDRM") == 0) {



	setQuit = 1;
	checkInput = 1;
	if (!SdlTkX.arg_nogl) {
	    /* Try to pre-load libGL.so for 3D canvas. */
	    dlopen("libGL.so.1", RTLD_NOW | RTLD_GLOBAL);
	}
    } else if (strcmp(p, "jsmpeg") == 0) {
................................................................................
	SDL_GL_SetAttribute(SDL_GL_DEPTH_SIZE, 24);
	SDL_GL_SetAttribute(SDL_GL_STENCIL_SIZE, 8);
    }
#endif

#ifdef linux
    if (setQuit) {



	atexit(DoSDLQuit);
    }
#endif

    /* Preset some defaults. */
    SdlTkX.dec_frame_width = 6;
    SdlTkX.dec_title_height = 20;
................................................................................
	    qevent = next;
	}
	SdlTkX.display->head = SdlTkX.display->tail = NULL;
	SdlTkX.display->qlen = 0;
	Tcl_MutexUnlock((Tcl_Mutex *) &SdlTkX.display->qlock);
    }
    SDL_RemoveTimer(timerId);


    /* Tear down font manager/engine. */






    SdlTkGfxDeinitFC();


eventThreadEnd:
#ifdef __APPLE__
    exit(3);
#else
    Tcl_ExitThread(0);
    TCL_THREAD_CREATE_RETURN;
#endif







>
>







 







|







 







>
>
>







 







>
>
>







 







>
>
|
>
>
>
>
>
>
|
>
>







49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
....
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
5450
5451
5452
....
5547
5548
5549
5550
5551
5552
5553
5554
5555
5556
5557
5558
5559
5560
5561
5562
5563
....
5610
5611
5612
5613
5614
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
....
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

#ifdef AGG_CUSTOM_ALLOCATOR
/* AGG custom allocator functions */
void *(*agg_custom_alloc)(unsigned int size) = NULL;
void (*agg_custom_free)(void *ptr) = NULL;
#endif

static int setQuit = 0;		/* True when atexit() handler set. */

TCL_DECLARE_MUTEX(atom_mutex);
static int atom_initialized = 0;
static Tcl_HashTable atom_table;
static int prop_initialized = 0;
static Tcl_HashTable prop_table;

struct RootSizeRequest {
................................................................................
    SDL_PixelFormat *pfmt;
    int xdpi, ydpi;
    int initMask = SDL_INIT_VIDEO | SDL_INIT_JOYSTICK;
#ifndef ANDROID
    int tfmt = SDL_PIXELFORMAT_RGB888;
#endif
#ifdef linux
    int checkInput = 0;
    char *p;
#elif defined(__APPLE__) || defined(_WIN32)
    char *p;
#endif
    XGCValues values;

#ifdef AGG_CUSTOM_ALLOCATOR
................................................................................
	setQuit = 1;
	checkInput = 1;
	/*
	 * -sdlfullscreen with RPI driver doesn't work.
	 */
	SdlTkX.arg_fullscreen = 0;
    } else if (strcmp(p, "KMSDRM") == 0) {
	/*
	 * See above, keyboard state.
	 */
	setQuit = 1;
	checkInput = 1;
	if (!SdlTkX.arg_nogl) {
	    /* Try to pre-load libGL.so for 3D canvas. */
	    dlopen("libGL.so.1", RTLD_NOW | RTLD_GLOBAL);
	}
    } else if (strcmp(p, "jsmpeg") == 0) {
................................................................................
	SDL_GL_SetAttribute(SDL_GL_DEPTH_SIZE, 24);
	SDL_GL_SetAttribute(SDL_GL_STENCIL_SIZE, 8);
    }
#endif

#ifdef linux
    if (setQuit) {
	/*
	 * See above, keyboard state.
	 */
	atexit(DoSDLQuit);
    }
#endif

    /* Preset some defaults. */
    SdlTkX.dec_frame_width = 6;
    SdlTkX.dec_title_height = 20;
................................................................................
	    qevent = next;
	}
	SdlTkX.display->head = SdlTkX.display->tail = NULL;
	SdlTkX.display->qlen = 0;
	Tcl_MutexUnlock((Tcl_Mutex *) &SdlTkX.display->qlock);
    }
    SDL_RemoveTimer(timerId);

    /*
     * Tear down font manager/engine. Do this only when no
     * atexit() handler is set. This is a workaround when
     * e.g. the tkvlc extension is used which otherwise seems
     * to cause heap corruption which hits the font cache
     * destructors.
     */
    if (!setQuit) {
	SdlTkGfxDeinitFC();
    }

eventThreadEnd:
#ifdef __APPLE__
    exit(3);
#else
    Tcl_ExitThread(0);
    TCL_THREAD_CREATE_RETURN;
#endif

Changes to undroid/tkvlc/generic/tkvlc.c.

93
94
95
96
97
98
99

100
101
102
103
104
105
106
...
389
390
391
392
393
394
395



396
397
398
399
400
401
402
...
470
471
472
473
474
475
476



477
478
479
480
481
482
483
...
557
558
559
560
561
562
563



564
565
566
567
568
569
570
....
1116
1117
1118
1119
1120
1121
1122




























1123
1124
1125
1126
1127
1128
1129
....
1131
1132
1133
1134
1135
1136
1137

1138
1139
1140
1141
1142
1143
1144
....
1173
1174
1175
1176
1177
1178
1179

1180
1181
1182
1183
1184
1185
1186
....
1315
1316
1317
1318
1319
1320
1321

1322
1323
1324
1325
1326
1327
1328
typedef struct libVLCData {
  libvlc_instance_t *vlc_inst;		/* libvlc library instance data. */
  Tcl_Interp *interp;			/* Associated Tcl interpreter. */
  Tcl_Command cmd;			/* Tcl command token. */
  libvlc_media_player_t *media_player;	/* libvlc media player. */
  int repeat;				/* If true, replay media. */
  int tk_checked;			/* True when Tk available. */

  Tcl_WideInt window_id;		/* Platform handle, if photo unused. */
  Tcl_Obj *file_name;			/* Filename of last opened media. */
  Tcl_Obj *photo_name;			/* Name of photo image or NULL. */
  int width, height;			/* Width and height for photo image. */
  Tcl_ThreadId tid;			/* Thread identifier of interpreter. */
  Tcl_Mutex ev_lock;			/* Mutex for ev_queue. */
  libVLCEvent *ev_queue;		/* Queued events minus frame events. */
................................................................................

static void libVLChandler(const struct libvlc_event_t *ev, void *clientData)
{
  libVLCData *p = (libVLCData *) clientData;
  libVLCEvent *e;
  int type;




  if (p->media_player == NULL) {
    return;
  }
  switch (ev->type) {
    case libvlc_MediaPlayerMediaChanged:
      type = EV_MEDIA_CHANGED;
      break;
................................................................................
  int docb = 0;

  if (f == NULL) {
    /* about to tear down media player */
    return 1;
  }
  p = f->p;



  interp = p->interp;
  photo = Tk_FindPhoto(interp, Tcl_GetString(p->photo_name));
  if (photo == NULL) {
    libvlc_media_player_stop(p->media_player);
  } else if (libvlc_media_player_is_playing(p->media_player) == 1) {
    Tk_PhotoImageBlock blk;

................................................................................

static void libVLCdisplay(void *clientData, void *picture)
{
  libVLCData *p = (libVLCData *) clientData;
  libVLCFrame *f = (libVLCFrame *) picture;
  libVLCEvent *e;




  if ((f == &p->frames[0] && p->frames[1].busy) ||
      (f == &p->frames[1] && p->frames[0].busy)) {
    /* other frame buffer still in use, drop frame */
    return;
  }
  e = (libVLCEvent *) ckalloc(sizeof(*e));
  e->header.proc = libVLCready;
................................................................................
  Tcl_MutexFinalize(&p->ev_lock);
  ckfree(p);
}

/*
 *----------------------------------------------------------------------
 *




























 * libVLCObjCmdDeleted --
 *
 *	Destructor of libvlc media player object and command.
 *
 * Results:
 *	None.
 *
................................................................................
 *	Resources are released.
 *
 *----------------------------------------------------------------------
 */

static void libVLCObjCmdDeleted(ClientData clientData)
{

  Tcl_EventuallyFree((char *) clientData, FreeData);
}

/*
 *----------------------------------------------------------------------
 *
 * TKVLC_INIT --
................................................................................
  }
  p = (libVLCData *) ckalloc(sizeof(*p));
  p->vlc_inst = NULL;
  p->interp = interp;
  p->media_player = NULL;
  p->repeat = 0;
  p->tk_checked = 0;

  p->window_id = 0;
  p->file_name = NULL;
  p->photo_name = NULL;
  p->width = p->height = 0;
  p->tid = Tcl_GetCurrentThread();
  p->ev_lock = NULL;
  p->ev_queue = NULL;
................................................................................
    libvlc_event_attach(em, libvlc_MediaPlayerUnmuted, libVLChandler, p);
    libvlc_event_attach(em, libvlc_MediaPlayerAudioVolume, libVLChandler, p);
    libvlc_event_attach(em, libvlc_MediaPlayerAudioDevice, libVLChandler, p);
  }
  zArg = Tcl_GetStringFromObj(objv[1], 0);
  p->cmd = Tcl_CreateObjCommand(interp, zArg, libVLCObjCmd, (ClientData) p,
				libVLCObjCmdDeleted);

  return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tkvlc_Init --







>







 







>
>
>







 







>
>
>







 







>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>







 







>







 







>







93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
...
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
...
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
...
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
....
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
....
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
....
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
....
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
typedef struct libVLCData {
  libvlc_instance_t *vlc_inst;		/* libvlc library instance data. */
  Tcl_Interp *interp;			/* Associated Tcl interpreter. */
  Tcl_Command cmd;			/* Tcl command token. */
  libvlc_media_player_t *media_player;	/* libvlc media player. */
  int repeat;				/* If true, replay media. */
  int tk_checked;			/* True when Tk available. */
  int exit_called;			/* True when finalizing. */
  Tcl_WideInt window_id;		/* Platform handle, if photo unused. */
  Tcl_Obj *file_name;			/* Filename of last opened media. */
  Tcl_Obj *photo_name;			/* Name of photo image or NULL. */
  int width, height;			/* Width and height for photo image. */
  Tcl_ThreadId tid;			/* Thread identifier of interpreter. */
  Tcl_Mutex ev_lock;			/* Mutex for ev_queue. */
  libVLCEvent *ev_queue;		/* Queued events minus frame events. */
................................................................................

static void libVLChandler(const struct libvlc_event_t *ev, void *clientData)
{
  libVLCData *p = (libVLCData *) clientData;
  libVLCEvent *e;
  int type;

  if (p->exit_called == NULL) {
    return;
  }
  if (p->media_player == NULL) {
    return;
  }
  switch (ev->type) {
    case libvlc_MediaPlayerMediaChanged:
      type = EV_MEDIA_CHANGED;
      break;
................................................................................
  int docb = 0;

  if (f == NULL) {
    /* about to tear down media player */
    return 1;
  }
  p = f->p;
  if (p->exit_called) {
    return 1;
  }
  interp = p->interp;
  photo = Tk_FindPhoto(interp, Tcl_GetString(p->photo_name));
  if (photo == NULL) {
    libvlc_media_player_stop(p->media_player);
  } else if (libvlc_media_player_is_playing(p->media_player) == 1) {
    Tk_PhotoImageBlock blk;

................................................................................

static void libVLCdisplay(void *clientData, void *picture)
{
  libVLCData *p = (libVLCData *) clientData;
  libVLCFrame *f = (libVLCFrame *) picture;
  libVLCEvent *e;

  if (p->exit_called) {
    return;
  }
  if ((f == &p->frames[0] && p->frames[1].busy) ||
      (f == &p->frames[1] && p->frames[0].busy)) {
    /* other frame buffer still in use, drop frame */
    return;
  }
  e = (libVLCEvent *) ckalloc(sizeof(*e));
  e->header.proc = libVLCready;
................................................................................
  Tcl_MutexFinalize(&p->ev_lock);
  ckfree(p);
}

/*
 *----------------------------------------------------------------------
 *
 * libVLCExitHandler --
 *
 *	Called on exit of process.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets a flag to invalidate further event handling.
 *
 *----------------------------------------------------------------------
 */

static void libVLCExitHandler(ClientData clientData)
{
  libVLCData *p = (libVLCData *) clientData;

  if (!p->exit_called) {
    p->exit_called = 1;
    if (p->media_player) {
      libvlc_media_player_stop(p->media_player);
    }
  }
}

/*
 *----------------------------------------------------------------------
 *
 * libVLCObjCmdDeleted --
 *
 *	Destructor of libvlc media player object and command.
 *
 * Results:
 *	None.
 *
................................................................................
 *	Resources are released.
 *
 *----------------------------------------------------------------------
 */

static void libVLCObjCmdDeleted(ClientData clientData)
{
  Tcl_DeleteExitHandler(libVLCExitHandler, clientData);
  Tcl_EventuallyFree((char *) clientData, FreeData);
}

/*
 *----------------------------------------------------------------------
 *
 * TKVLC_INIT --
................................................................................
  }
  p = (libVLCData *) ckalloc(sizeof(*p));
  p->vlc_inst = NULL;
  p->interp = interp;
  p->media_player = NULL;
  p->repeat = 0;
  p->tk_checked = 0;
  p->exit_called = 0;
  p->window_id = 0;
  p->file_name = NULL;
  p->photo_name = NULL;
  p->width = p->height = 0;
  p->tid = Tcl_GetCurrentThread();
  p->ev_lock = NULL;
  p->ev_queue = NULL;
................................................................................
    libvlc_event_attach(em, libvlc_MediaPlayerUnmuted, libVLChandler, p);
    libvlc_event_attach(em, libvlc_MediaPlayerAudioVolume, libVLChandler, p);
    libvlc_event_attach(em, libvlc_MediaPlayerAudioDevice, libVLChandler, p);
  }
  zArg = Tcl_GetStringFromObj(objv[1], 0);
  p->cmd = Tcl_CreateObjCommand(interp, zArg, libVLCObjCmd, (ClientData) p,
				libVLCObjCmdDeleted);
  Tcl_CreateExitHandler(libVLCExitHandler, (ClientData) p);
  return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tkvlc_Init --