tcltk2/0000755000176200001440000000000015017107032011451 5ustar liggesuserstcltk2/MD50000644000176200001440000012716515017107032011775 0ustar liggesusers7cd92dd0df0c0c1615f5e1d203f7dd8e *DESCRIPTION e6a1c0f4bf826639913db23e9174b99c *LICENSE.note f534b1ff8163e28c8a67f533440e9e17 *NAMESPACE c9d17e096ac8436111f48a70aaf363fc *R/setLanguage.R cc10276c183c0921d80dda383608cec3 *R/tclTask.R 59c87af761997af83872a70e2bf077ba *R/tclVarFun.R a440ec7f526c96eb1261a7bbeaba94dd *R/tcltk2-Internal.R 159f4aa7572b6f85ccc37a738c3c1ae3 *R/tcltk2-package.R 25dc8e02d976961f0e6143843b09de06 *R/tk2commands.R e2d2eccdbf168bc4d78768a4519783a5 *R/tk2dde.R 0fd8f21b3dbff3807e1698548448dcab *R/tk2dialogs.R 7a6555095d4b2de6bdd2e6b0f8daf33b *R/tk2edit.R bc55bb2d3f592a1563101c1b481cfb7a *R/tk2fonts.R b4126e1765d2f38ed55baa3eb22a6424 *R/tk2ico.R 672d3da063e8108d702a22aed825493c *R/tk2methods.R de1b3908bcc47b60385ec834217dce72 *R/tk2reg.R 823edb79568bf4aae7da95c6c9e386db *R/tk2swaplist.R 39b0404ef3649e50c540655888679c58 *R/tk2tip.R 6da24741d32c24884df826443831f001 *R/tk2widgets.R c1ca21949b3fbab63cfbf53c7fbc6238 *build/vignette.rds 3396b83daefb9b5d852b363682b4e87d *inst/CITATION f80b7a9244ddb6ec743347ff3e009f80 *inst/Fonts.txt 46750e778a5cdb4d65c347f8e43df623 *inst/doc/tcltk2.R 75444ed93db372522253766eb192bc51 *inst/doc/tcltk2.Rmd 183470f28c1879fcda05b5819f3f28a2 *inst/doc/tcltk2.html d7beacc2b4a432efef415f26f828be80 *inst/gui/SciViews.gif c8f294a7ba9953aae2e0ee08e6a4cddd *inst/gui/SciViews.ico 950c4c517f77f72f57ca5511b8c98d1b *inst/po/fr/LC_MESSAGES/R-tcltk2.mo 1d068d81412640fff282340ac32f96c2 *inst/tklibs/Diagrams0.2/ChangeLog 6558863932ef3fbe5a4a833062c4d983 *inst/tklibs/Diagrams0.2/draw_diagram.man dcc7810a9faa2a9544bf02c391446aec *inst/tklibs/Diagrams0.2/draw_diagram.tcl cb52df39a372b379f262af4cd7455723 *inst/tklibs/Diagrams0.2/example_anchor.tcl 1cbfb045e5c0e3b00d78636637f869e2 *inst/tklibs/Diagrams0.2/example_chemical.tcl 50e312b9e7a4bd14b941f674f0f060f9 *inst/tklibs/Diagrams0.2/example_circle.tcl 3628bd23b259e0d183e81a64caa256d6 *inst/tklibs/Diagrams0.2/example_fraction.tcl 6082f548a6f7e2eac37fa9389d911383 *inst/tklibs/Diagrams0.2/example_heater.tcl d38c2050b0d363b282ab8614e9d9b976 *inst/tklibs/Diagrams0.2/pkgIndex.tcl bc63f7276bc00ac4fa605f5e7e7b9049 *inst/tklibs/autoscroll1.1/ChangeLog 7fec716ca3f427cc7ad2ca1e84f4d02a *inst/tklibs/autoscroll1.1/autoscroll.man 615c16f11354b9b88aa84252f064be05 *inst/tklibs/autoscroll1.1/autoscroll.tcl fced6d9b00c198b56df95a3a1b1d0179 *inst/tklibs/autoscroll1.1/example.tcl b64f6fc48d63dd9d5e4ac59ed5919274 *inst/tklibs/autoscroll1.1/pkgIndex.tcl 1a77b65fa40f535c6a6ca823067df858 *inst/tklibs/choosefont/choosefont.tcl 807bb70e684dabc0ab6f0cf7345b7f2e *inst/tklibs/choosefont/example.tcl c03587d1efd3867595b837108a9c1a50 *inst/tklibs/choosefont/msgs/de.msg 4c97ffc1574b6a28de4387e2eb86973b *inst/tklibs/choosefont/msgs/en.msg 82c04a5c629611978363eae0dd30d3c4 *inst/tklibs/choosefont/msgs/fr.msg 73c8f470697b35ae8a9d72620de76f87 *inst/tklibs/choosefont/pkgIndex.tcl 883a2f8a7fdf56629b5e31e27b3051c8 *inst/tklibs/cmdline1.5.3/ChangeLog d706f7c861d7293f736a198c9313fb4c *inst/tklibs/cmdline1.5.3/cmdline.man ae87450f498c990d5114626416748db6 *inst/tklibs/cmdline1.5.3/cmdline.tcl 9e0eb81d4431ada4005881773db69979 *inst/tklibs/cmdline1.5.3/cmdline.test 6403daeaef8c4db9d73194e9609f1211 *inst/tklibs/cmdline1.5.3/pkgIndex.tcl 547130c8feaee0e1d1a84298333d0ac3 *inst/tklibs/cmdline1.5.3/typedCmdline.test c22ab99adbc28a1941c194719b28130d *inst/tklibs/combobox2.3/ANNOUNCE.txt 2c4abf3fc88424cbd68cdca12447d555 *inst/tklibs/combobox2.3/CHANGES.txt 1931bb5d5078afb9960de79d16b992d7 *inst/tklibs/combobox2.3/README.txt 67cb83175ab6671120072f0524030798 *inst/tklibs/combobox2.3/combobox.html 2d6f44ba17dcc8c646ae09d1cfb29f53 *inst/tklibs/combobox2.3/combobox.n 05fe534a5915ca5088a38c070465c970 *inst/tklibs/combobox2.3/combobox.tcl fbbf32fc86a97af79a00638d7ed93d44 *inst/tklibs/combobox2.3/combobox.tmml b6fad85c214ec21db6235f8a5c5d8704 *inst/tklibs/combobox2.3/example.tcl c6a215d93adeceb7b50410a390e962f6 *inst/tklibs/combobox2.3/pkgIndex.tcl 05875a448c3324de8d588d9875f6bf9e *inst/tklibs/ctext3.3/BUGS facdfb65e1962ce144f678566dc3c6bb *inst/tklibs/ctext3.3/ChangeLog c72554283193e887741cc2db36d23e93 *inst/tklibs/ctext3.3/LICENSE 8248b2af20faa02412cff64d8dfb210b *inst/tklibs/ctext3.3/README 439b0bc58882b73eba582a6f9551510b *inst/tklibs/ctext3.3/REGRESSION b8bd00e1f068d4010e76261f384eb9d4 *inst/tklibs/ctext3.3/TODO 1295ee6261410bbe87469a2a48f640fc *inst/tklibs/ctext3.3/ctext.man 551a081b85ca071078e46a0aeac11ed3 *inst/tklibs/ctext3.3/ctext.tcl 2e933bbe9bb5a49557b17256c42b9b31 *inst/tklibs/ctext3.3/ctext_scroll_test.tcl f9dcfc246d3b038fce16a7d5df1fb503 *inst/tklibs/ctext3.3/ctext_tcl.tcl d5c039a972f155a0f38a35e4e440e400 *inst/tklibs/ctext3.3/ctext_test.tcl 1121d9be9b2cc16fd6e535935af08136 *inst/tklibs/ctext3.3/ctext_test_c.tcl 166665765dc513a9578e0460fac3e1e5 *inst/tklibs/ctext3.3/ctext_test_interactive.tcl 99f2647eab1a73545a9c3c4eb6724937 *inst/tklibs/ctext3.3/ctext_test_ws.tcl 86708f94ba4ce244d335242e9c5ae018 *inst/tklibs/ctext3.3/function_finder.tcl 7701d8a5281fa313b9dbf74af21e7900 *inst/tklibs/ctext3.3/install.tcl ecf7a264ff85e9f486ad1b8ad9015ac4 *inst/tklibs/ctext3.3/long_test_script c32223a0ff037c8955bc0053060d2b15 *inst/tklibs/ctext3.3/pkgIndex.tcl e8d332e1b37ffe721c5ae4c02db7d697 *inst/tklibs/ctext3.3/test.c b24bca6f58f9dd7d7361b831c3fbbe51 *inst/tklibs/cursor0.3.1/ChangeLog 28487b8bd81924bf8510550daea71997 *inst/tklibs/cursor0.3.1/cursor.man dd70bf353d94af7813c7a45530106071 *inst/tklibs/cursor0.3.1/cursor.tcl b31466f412fedbbacba0d354392466ab *inst/tklibs/cursor0.3.1/pkgIndex.tcl 83df78d82dfa8fa1ae0f1db05d8e7e7d *inst/tklibs/datefield0.3/ChangeLog a84cf5e4800f92a7a727e20d83ecf74d *inst/tklibs/datefield0.3/datefield.man f659db4acfd5f50596d6f5ffc83517e0 *inst/tklibs/datefield0.3/datefield.tcl efcf11b0abd84180c01870ed20658357 *inst/tklibs/datefield0.3/pkgIndex.tcl 60917ef46e547dcc7929e71cbb263e56 *inst/tklibs/fonts.tcl 6f769278cc649a16a50803711c74b4f4 *inst/tklibs/getstring0.1/ChangeLog d83d33a7f4ce452d509d44703503b28c *inst/tklibs/getstring0.1/example.tcl 95ef3d941ac9682fd3839651f7f7d3ff *inst/tklibs/getstring0.1/pkgIndex.tcl 36a977c8e529c5cf6b9944d42592ac0d *inst/tklibs/getstring0.1/tk_getString.man 4465cc14ca6eaf67def63b7f37542b79 *inst/tklibs/getstring0.1/tk_getString.tcl adecb7ac837eda1ac7816bc97e2974e1 *inst/tklibs/history0.3/ChangeLog 10bf3ea0d6e7907eaa21ac3172c049eb *inst/tklibs/history0.3/example.tcl b2c9742b5e3f088aa224aec2bfffb11d *inst/tklibs/history0.3/history.tcl 0f47e1ad0e4635f89d96cc9e23398a8a *inst/tklibs/history0.3/pkgIndex.tcl 54008b67309de4ee101b44925e655164 *inst/tklibs/history0.3/tklib_history.man 9b0e6f2a8d1b7821abd1e7121dc29e29 *inst/tklibs/ico1.1/ChangeLog 74b23296da756c9ce64516432b3216b0 *inst/tklibs/ico1.1/ico.man c734dbb97f21ca30d69488f071b965a7 *inst/tklibs/ico1.1/ico.tcl 76b8f14ef5e556d608efda507a9a3fe4 *inst/tklibs/ico1.1/ico0.tcl 51e6961799b8a412a16d6e7fee16b9ef *inst/tklibs/ico1.1/pkgIndex.tcl d50239da3d1b59aa6276bef61e5e0d0a *inst/tklibs/ipentry0.3/ChangeLog 1acef9c0a89b18bf5bbbc2953d4eca1c *inst/tklibs/ipentry0.3/ipentry.man 36bc01454ae8ba54a99bc762f264173e *inst/tklibs/ipentry0.3/ipentry.tcl 963599ff857793c8abc30674023666ec *inst/tklibs/ipentry0.3/pkgIndex.tcl 0bb76ec8e04db27330c1e129cb32e378 *inst/tklibs/khim1.0/ChangeLog 63bec5de24408e6764fe810b3d915f7a *inst/tklibs/khim1.0/ROOT.msg 9ea3808cf158d1679fe27d3479d72c2c *inst/tklibs/khim1.0/cs.msg 97b3646fc85d314baa535ba56190831d *inst/tklibs/khim1.0/da.msg 5dd4d2c38865829a7fcd002db1bcfc64 *inst/tklibs/khim1.0/de.msg 66166f82636a438255edb37dafb3b4e9 *inst/tklibs/khim1.0/en.msg ee0be4e535510e9d7aa3736c73da7d52 *inst/tklibs/khim1.0/es.msg 4a8556f892211b92e21325f892245098 *inst/tklibs/khim1.0/khim.man cad7a1cf49680f9ccce1ccc3d50c3a8f *inst/tklibs/khim1.0/khim.tcl 1227991ca9b9b8699409eaf5be496658 *inst/tklibs/khim1.0/pkgIndex.tcl c556db3416157fc66ec3a65444f70ee2 *inst/tklibs/khim1.0/pl.msg b4b635c1875f12c7843fb87f59e557ea *inst/tklibs/khim1.0/ru.msg 947feb28f7f1c11d729b69da97347096 *inst/tklibs/khim1.0/uk.msg fde0ad169b047dfa65aa818eed4a8652 *inst/tklibs/mclistbox1.02/ANNOUNCE.txt 472304d637f5db2ab3c4f1963945517a *inst/tklibs/mclistbox1.02/CHANGES.txt 603937c4eb80360eb2455401182bcf27 *inst/tklibs/mclistbox1.02/README.txt bb2df0f05bf08245fdb3e5646145890b *inst/tklibs/mclistbox1.02/defs c48a6c75bb52c063db1a589a45fb7130 *inst/tklibs/mclistbox1.02/example.tcl f1e7d3b3a5ec672f553c24b7a542c184 *inst/tklibs/mclistbox1.02/mclistbox.html f537b5f758b4d552739c817e0a1f4d77 *inst/tklibs/mclistbox1.02/mclistbox.pod ff9bf448118969f7271b8964234af0a4 *inst/tklibs/mclistbox1.02/mclistbox.tcl 522d18460848e95ae1b2fc6af3240130 *inst/tklibs/mclistbox1.02/mclistbox.test a3299d0cecc095624efce965d798958a *inst/tklibs/mclistbox1.02/pkgIndex.tcl 1f0e6c9ebd33ef12779c7774eece0057 *inst/tklibs/mclistbox1.02/test.tcl 2aa71f90742b3d48eb69ab705f31f8e0 *inst/tklibs/notebook1.3/example.tcl 7a0202a5d3d7531756307978c69afb1e *inst/tklibs/notebook1.3/notebook.tcl d107babcfdca929a0036529f74fa1cc6 *inst/tklibs/ntext1.0/ChangeLog 22a883e977c234a203cc92233b340d78 *inst/tklibs/ntext1.0/NtextBindings.html cd384b8ace29c04aa41d73037190da3e *inst/tklibs/ntext1.0/TkTextBindings.html 2690d1114dacf21d71a8cafa488f2239 *inst/tklibs/ntext1.0/ntext.man 42a5e11b1a1a6dad0e5efcb62a154f98 *inst/tklibs/ntext1.0/ntext.sed 70b564de5914504420b2cfb24bce690f *inst/tklibs/ntext1.0/ntext.tcl 1ad38efc862baec141cbe43f5465c0d0 *inst/tklibs/ntext1.0/ntextBindings.man da673d273240531077b87bb1a1405417 *inst/tklibs/ntext1.0/ntextIndent.man 070136378b523dcbc5061bf2b10096a3 *inst/tklibs/ntext1.0/ntextWordBreak.man b2cbb3763cc574585f45ea543a7e0027 *inst/tklibs/ntext1.0/pkgIndex.tcl 8b10516da7b0c456c255097ec23b594f *inst/tklibs/scrolledWidget.tcl b82e1a280e24a24f3ee37aa6fcfb849a *inst/tklibs/snit2.3.4/ChangeLog 4932ca1c1454e97c3f0f2516ed36251e *inst/tklibs/snit2.3.4/README.tcl83.txt 92b247547aa7ff242b265244d470f5af *inst/tklibs/snit2.3.4/README.txt 77a4bdf0313d0c25fdd51aed5b0a9f1d *inst/tklibs/snit2.3.4/dictionary.txt cb28d2135e7f836e4fd3c3381527fbc7 *inst/tklibs/snit2.3.4/license.txt dd7d74dd2a9c62ea045e1b0792e05b6e *inst/tklibs/snit2.3.4/main1.tcl 8bd02ba9798f98c8fbb30aea67a0857f *inst/tklibs/snit2.3.4/main2.tcl 329cfc5a723e05e08a8530f5d361e6ee *inst/tklibs/snit2.3.4/modules.txt fe1302a820ca0e5eb7426d7543e03f71 *inst/tklibs/snit2.3.4/pkgIndex.tcl 814f99ee710d09992b718b6b7cfd0451 *inst/tklibs/snit2.3.4/roadmap.txt ffab1eddf149e546f3bcea49c21d922b *inst/tklibs/snit2.3.4/roadmap2.txt 64b1af51abeac3d1bfc14d8aa8ee8fc5 *inst/tklibs/snit2.3.4/snit.man c619db6c97a840362f2147391d3dd160 *inst/tklibs/snit2.3.4/snit.tcl 268baaad8c10da83d48706d3bbc724ad *inst/tklibs/snit2.3.4/snit.test 34355e243c6840a6b9acbf683b27ca81 *inst/tklibs/snit2.3.4/snit2.tcl 15d560c9836cd231c03cf7f2173f2d7a *inst/tklibs/snit2.3.4/snitfaq.man 5697a016a08df983d4131a96022af517 *inst/tklibs/snit2.3.4/validate.tcl c5b1625c3ac1ffcf5734c3475724842b *inst/tklibs/struct2.2/ChangeLog dc273e175a13635b32f7c504d989a377 *inst/tklibs/struct2.2/list.tcl 1ec857f626085d992a4f6c793a8bc7cb *inst/tklibs/struct2.2/list.test b0232952a9227199749ad7ed496798b1 *inst/tklibs/struct2.2/list.test.tcl ffeed19fc8370189a7d7de16f1631010 *inst/tklibs/struct2.2/matrix.man 1e3981d0e819764fd03bf21112fe536f *inst/tklibs/struct2.2/matrix.tcl 424ff349128da7a1dd141e4f4aadb390 *inst/tklibs/struct2.2/matrix.test d9614031cd20396efa55509f4d935b4d *inst/tklibs/struct2.2/matrix.testsupport 2839408691038f829bd7b982b0ef46d9 *inst/tklibs/struct2.2/pkgIndex.tcl 4545f81f929bef4a4c93c8ebab4270dd *inst/tklibs/struct2.2/struct.tcl 957502a0bbe2e7ee2b667b1b5b7a674c *inst/tklibs/struct2.2/struct_list.man 4a5ff10bef0dab714ab40a75ee4e4f5e *inst/tklibs/swaplist0.2/ChangeLog 441c02b0f75dd94609d8918b5bb85bc6 *inst/tklibs/swaplist0.2/example.tcl adee4d73d9c9798529d0e85644276f19 *inst/tklibs/swaplist0.2/pkgIndex.tcl 2fbc9cdcc07c405a8ee47d7c10aa353a *inst/tklibs/swaplist0.2/swaplist.man 460bb0f02bc76e6e8fefa87553f533ba *inst/tklibs/swaplist0.2/swaplist.tcl be893b2f028a51046b84d53cfd59c0b0 *inst/tklibs/tablelist7.6/CHANGES.txt ea14601aab935c383bc1e8da952849e8 *inst/tklibs/tablelist7.6/COPYRIGHT.txt c5f1fc1d322300714898bfb7f0f31047 *inst/tklibs/tablelist7.6/ChangeLog 44db779e0c22a87f44d0579011223699 *inst/tklibs/tablelist7.6/README.txt ba3841ae159ba66c16865d5e3b4f8b87 *inst/tklibs/tablelist7.6/pkgIndex.tcl 69bf60b7a844482184bbbad58db13547 *inst/tklibs/tablelist7.6/scripts/pencil.cur b1d210119ae4c75b79cc2458c72e6584 *inst/tklibs/tablelist7.6/scripts/tablelistBind.tcl f7c2bcfbc10f37ce18211f34e7fa4639 *inst/tklibs/tablelist7.6/scripts/tablelistConfig.tcl 58ae1a49ca59521e89e5a8194fed8e83 *inst/tklibs/tablelist7.6/scripts/tablelistEdit.tcl 622b2ae7e7bd07367eeb1d27404c2d61 *inst/tklibs/tablelist7.6/scripts/tablelistImages.tcl 76b7c10be09a934efa05e340d6382ccb *inst/tklibs/tablelist7.6/scripts/tablelistMove.tcl 2a60cf5c3409fb4e66589bb70d5f8c28 *inst/tklibs/tablelist7.6/scripts/tablelistSort.tcl 62d988d997e6f776b0ac7e458b492edc *inst/tklibs/tablelist7.6/scripts/tablelistThemes.tcl d440833c6a252b4f95f7d38299235423 *inst/tklibs/tablelist7.6/scripts/tablelistUtil.tcl 8b82ba31e5374f171ead0f04114407c2 *inst/tklibs/tablelist7.6/scripts/tablelistWidget.tcl 1de7a4c03e7b919b0065e4bfdae1314e *inst/tklibs/tablelist7.6/scripts/tclIndex 3ee051e71ddaa5329c74f15cfc88dee3 *inst/tklibs/tablelist7.6/scripts/utils/indicatorImgs/gifIndicatorImgs.tcl e0171f9c17bbc3d434d5800e91ba0691 *inst/tklibs/tablelist7.6/scripts/utils/indicatorImgs/svgIndicatorImgs.tcl 3fb228b8251f4fadf96165cb0fd86d69 *inst/tklibs/tablelist7.6/scripts/utils/indicatorImgs/tclIndex f29d05295e455feac0da286db770a70a *inst/tklibs/tablelist7.6/scripts/utils/mwutil.tcl 5b4bc43cdd7754c993a27ecddaeb083a *inst/tklibs/tablelist7.6/scripts/utils/pkgIndex.tcl 9603e93724fb6a3b31e0cdefec9d4aed *inst/tklibs/tablelist7.6/scripts/utils/scaleutil.tcl 9885c493af6250b606d1d6ddcf2e72dd *inst/tklibs/tablelist7.6/scripts/utils/scaleutilMisc.tcl 7e6eed5d066308088f8ba2d47f45ec40 *inst/tklibs/tablelist7.6/scripts/utils/themepatch.tcl f6ce02e70a9ea884c31986aca9d6c739 *inst/tklibs/tablelist7.6/tablelist.tcl c3fdf46e41fab2007628d946d52d6240 *inst/tklibs/tablelist7.6/tablelistCommon.tcl a3a18033f0e8f3f3f691b6dd145da9e5 *inst/tklibs/tablelist7.6/tablelist_tile.tcl edf2202e477e06914250540df7d21ca8 *inst/tklibs/textutil0.10/ChangeLog 5c67e088bfb17567fe6e01a79cc6fb5c *inst/tklibs/textutil0.10/adjust.man 099aaaddb9502c5066cd0039f6cb68d3 *inst/tklibs/textutil0.10/adjust.tcl 35b9a19b286bc1f53f02d9e1763bbb0d *inst/tklibs/textutil0.10/adjust.test 7b61ef10c9a3d4956dd4b2acecaa5735 *inst/tklibs/textutil0.10/adjust_hyph.test d50f460a376f0889af5f13632024d51b *inst/tklibs/textutil0.10/expander.ehtml 4121a3f4cf91821b17d4ba477898406b *inst/tklibs/textutil0.10/expander.man ca83b516b26b91c4e28fa8d9054f57f0 *inst/tklibs/textutil0.10/expander.tcl 9ad316c21a6cde9a1f7e974a156f0065 *inst/tklibs/textutil0.10/expander.test cb28d2135e7f836e4fd3c3381527fbc7 *inst/tklibs/textutil0.10/expander_license.txt 110d29d37e251c1dde71cce0b453e3fa *inst/tklibs/textutil0.10/expander_notes.txt d095a78c8622bf86d0d24b2ed4e4accc *inst/tklibs/textutil0.10/patch.man bcbe0a37f6913229dfbeddff61f7d6eb *inst/tklibs/textutil0.10/patch.tcl 3f95338e0393d8298217954b7673bca8 *inst/tklibs/textutil0.10/patch.test b9e7e130b3a5af8ea442b7a546433b2a *inst/tklibs/textutil0.10/pkgIndex.tcl 19fddd92714e18b867878d518e6ddf45 *inst/tklibs/textutil0.10/repeat.man 3805d3afe20918b70f4dfa405f2284c3 *inst/tklibs/textutil0.10/repeat.tcl 74f56e4b0ccc84bd187e4cddda451e7d *inst/tklibs/textutil0.10/repeat.test 0c986f1cd6129b8dac6d90e55b62bf35 *inst/tklibs/textutil0.10/split.tcl 9029cb7d9806a0e80673f5693bf5788a *inst/tklibs/textutil0.10/split.test 0722f1359d067701d1bd4ae10d43e3ed *inst/tklibs/textutil0.10/string.bench 81d92c0e6c48fd37c5e7d8dfbf707aa6 *inst/tklibs/textutil0.10/string.tcl d3375430e866c0b90757c8a7fabe0382 *inst/tklibs/textutil0.10/tabify.man 11fa1237d8096ccbc0b0606ee81a5b62 *inst/tklibs/textutil0.10/tabify.tcl 64d6edb4d83121c6076d6d351af82372 *inst/tklibs/textutil0.10/tabify.test 8fa1ed9ad903eb324f91581503b042f6 *inst/tklibs/textutil0.10/textutil.man 7a2bcd12e56a0fd5e4649f3f4950d4db *inst/tklibs/textutil0.10/textutil.tcl c4cf6b7b41e1a3acb45de3a473757da8 *inst/tklibs/textutil0.10/textutil.test de9d4c4dd140f1afbb421e0aebef1b5e *inst/tklibs/textutil0.10/textutil_split.man 95dcb03a07ef5bfbac0d44df9370143d *inst/tklibs/textutil0.10/textutil_string.man ed5be463f81ca4da5f95508e61cd28f9 *inst/tklibs/textutil0.10/trim.man e3374495e9d5ccd1bebfe2bb1a6c33e6 *inst/tklibs/textutil0.10/trim.tcl f5d44d10fcf6de0955512c5e838f887f *inst/tklibs/textutil0.10/trim.test 9a57e9604d6284ced353e0355bf782d3 *inst/tklibs/textutil0.10/wcswidth.bench bb925f9ac0f5ef335608b3ebf8e2b319 *inst/tklibs/textutil0.10/wcswidth.man 5eeda81f137676b530b677d785eea7b4 *inst/tklibs/textutil0.10/wcswidth.tcl 700d811611c975d7274fb0deeb105e16 *inst/tklibs/textutil0.10/wcswidth.test d112906a566db928f3b93c0ce54e5c03 *inst/tklibs/tooltip2.0.1/ChangeLog 73c54d3ef51cab32eb47a06f733c2c4a *inst/tklibs/tooltip2.0.1/example.tcl cb89e8f200e6f8beef8a23f7ededf7fb *inst/tklibs/tooltip2.0.1/pkgIndex.tcl 3020fd8f28424ab49dc8d8c992576e51 *inst/tklibs/tooltip2.0.1/tipstack.man aff98a6f822bde387d631894033a52a8 *inst/tklibs/tooltip2.0.1/tipstack.tcl dae066bd3a551c05df2b596a1e43ca50 *inst/tklibs/tooltip2.0.1/tooltip.man cb9c1dbd03e5b5ee60b683eb58db6537 *inst/tklibs/tooltip2.0.1/tooltip.tcl af5281d35846c152dc14badd4e77e6c0 *inst/tklibs/tree1.7/example.tcl d075ed820f94beda8ca8f73294bbd08a *inst/tklibs/tree1.7/tree.tcl 9da38184e5a73080dd4c831f3627c824 *inst/tklibs/ttktheme_clearlooks/clearlooks/arrowdown-a.gif 506818e0e9a896e171834bc99e8c3d44 *inst/tklibs/ttktheme_clearlooks/clearlooks/arrowdown-d.gif caa904a161d2c2664afecc0d19fa29ec *inst/tklibs/ttktheme_clearlooks/clearlooks/arrowdown-n.gif 90721e0804be1f66d023d42a8e729a0c *inst/tklibs/ttktheme_clearlooks/clearlooks/arrowdown-p.gif fe1e179e5ed321570787ee10644ebba7 *inst/tklibs/ttktheme_clearlooks/clearlooks/arrowleft-a.gif 7feb1ff35102c8ba38705a9a7f981fa5 *inst/tklibs/ttktheme_clearlooks/clearlooks/arrowleft-d.gif 6f610c75142393eaafbd934e4dfe9d35 *inst/tklibs/ttktheme_clearlooks/clearlooks/arrowleft-n.gif 51f742e27d39bda525f74766bde32dad *inst/tklibs/ttktheme_clearlooks/clearlooks/arrowleft-p.gif 5fa215939ab69a998e97b9b08d546c1f *inst/tklibs/ttktheme_clearlooks/clearlooks/arrowright-a.gif e6118070a7db3bc2fb30f65bda5b4b96 *inst/tklibs/ttktheme_clearlooks/clearlooks/arrowright-d.gif 78dc4885e35eadefd764194d72802c8c *inst/tklibs/ttktheme_clearlooks/clearlooks/arrowright-n.gif 6ab4841dd361d51e87786b90eb6ca35c *inst/tklibs/ttktheme_clearlooks/clearlooks/arrowright-p.gif 1bc879ddf2291792a6f99a86b146e993 *inst/tklibs/ttktheme_clearlooks/clearlooks/arrowup-a.gif 9fefdaa3f23794d8055776804da899d8 *inst/tklibs/ttktheme_clearlooks/clearlooks/arrowup-d.gif 49706b9c05feec0db91a1ee98a80bb43 *inst/tklibs/ttktheme_clearlooks/clearlooks/arrowup-n.gif 28de67e8a9999958845524da9ee2f9cc *inst/tklibs/ttktheme_clearlooks/clearlooks/arrowup-p.gif b1a1bad9caa9a8ea7e6fb57b7977bd6f *inst/tklibs/ttktheme_clearlooks/clearlooks/blank.gif ba99f727c097bf84083ef165314b6236 *inst/tklibs/ttktheme_clearlooks/clearlooks/button-a.gif 83f651271f016ef91124e32a0747666a *inst/tklibs/ttktheme_clearlooks/clearlooks/button-d.gif b0baa9480fe4401abe2e32567ccb6eb6 *inst/tklibs/ttktheme_clearlooks/clearlooks/button-n.gif fb09dea88691b697000a856b664fcd22 *inst/tklibs/ttktheme_clearlooks/clearlooks/button-p.gif 8a8480a16e1b241495e10eead276680f *inst/tklibs/ttktheme_clearlooks/clearlooks/button-pa.gif 354e98b24c5f259c80c13cbf651375c1 *inst/tklibs/ttktheme_clearlooks/clearlooks/check-ac.gif 7c0cd01676989a4f457ef7c4fbefdb2a *inst/tklibs/ttktheme_clearlooks/clearlooks/check-au.gif 7430972668c44bb12f0899c6b00d79dc *inst/tklibs/ttktheme_clearlooks/clearlooks/check-dc.gif 7c0cd01676989a4f457ef7c4fbefdb2a *inst/tklibs/ttktheme_clearlooks/clearlooks/check-du.gif 354e98b24c5f259c80c13cbf651375c1 *inst/tklibs/ttktheme_clearlooks/clearlooks/check-nc.gif 7c0cd01676989a4f457ef7c4fbefdb2a *inst/tklibs/ttktheme_clearlooks/clearlooks/check-nu.gif 9a3ace3c192855899d49c728ed629162 *inst/tklibs/ttktheme_clearlooks/clearlooks/check-pc.gif 35834f3929a24856c02468769d52cfbf *inst/tklibs/ttktheme_clearlooks/clearlooks/check-pu.gif c62fa340b3337219db1be15217d1d865 *inst/tklibs/ttktheme_clearlooks/clearlooks/combo-n.gif 202d118709e1255207af71d201dbd30a *inst/tklibs/ttktheme_clearlooks/clearlooks/combo-ra.gif 8d40018c0a18ffc6392bfbc695bb2a2b *inst/tklibs/ttktheme_clearlooks/clearlooks/combo-rd.gif ec60accf4bb75acc12859cee3773435b *inst/tklibs/ttktheme_clearlooks/clearlooks/combo-rf.gif 1e2ac586a6aa5fac7318043623e524a2 *inst/tklibs/ttktheme_clearlooks/clearlooks/combo-rn.gif 770af6661c5514b618830b6f15c6df22 *inst/tklibs/ttktheme_clearlooks/clearlooks/combo-rp.gif a15fff942d7b700310297bdd50b9faad *inst/tklibs/ttktheme_clearlooks/clearlooks/comboarrow-a.gif 28f09ef1f39deeca93294b6bd4f4170f *inst/tklibs/ttktheme_clearlooks/clearlooks/comboarrow-d.gif b749384a4cb89d284e4dd209c95a4a9d *inst/tklibs/ttktheme_clearlooks/clearlooks/comboarrow-n.gif b71c34cc9cd4801e4543029b10a98c71 *inst/tklibs/ttktheme_clearlooks/clearlooks/comboarrow-p.gif 89555d2e7571b79a6c2b4c4e0177cc2f *inst/tklibs/ttktheme_clearlooks/clearlooks/progress-h.gif 7bb1fba5147670c174a17f33b1703134 *inst/tklibs/ttktheme_clearlooks/clearlooks/progress-v.gif 8758d3e6e2970adbbc92c4843676b515 *inst/tklibs/ttktheme_clearlooks/clearlooks/radio-ac.gif 4255bf2083e3271cb8a1869eae3e8dc4 *inst/tklibs/ttktheme_clearlooks/clearlooks/radio-au.gif 49a203ea39e2ad263730e15167b4addd *inst/tklibs/ttktheme_clearlooks/clearlooks/radio-dc.gif 76051820fde72dd4f4e3548eae761bab *inst/tklibs/ttktheme_clearlooks/clearlooks/radio-du.gif bda3fc9a1db73987473ee3e845fddc1e *inst/tklibs/ttktheme_clearlooks/clearlooks/radio-nc.gif 76051820fde72dd4f4e3548eae761bab *inst/tklibs/ttktheme_clearlooks/clearlooks/radio-nu.gif d95aebdef7bc758a4ed7c0b307570216 *inst/tklibs/ttktheme_clearlooks/clearlooks/radio-pc.gif 2dc37d6b09629d1ca733a5c855ec1e48 *inst/tklibs/ttktheme_clearlooks/clearlooks/radio-pu.gif dddf3c11e0db6340b64664bbbda58651 *inst/tklibs/ttktheme_clearlooks/clearlooks/sbthumb-ha.gif 3ea001698333fa97299c45d3471d73aa *inst/tklibs/ttktheme_clearlooks/clearlooks/sbthumb-hd.gif b0b89af794117d23879e1180f2849efc *inst/tklibs/ttktheme_clearlooks/clearlooks/sbthumb-hn.gif b0b89af794117d23879e1180f2849efc *inst/tklibs/ttktheme_clearlooks/clearlooks/sbthumb-hp.gif 31b05e29c33a6c570b091d870e28f250 *inst/tklibs/ttktheme_clearlooks/clearlooks/sbthumb-va.gif e1d59850b97c7b8014fcbb7c3213bd17 *inst/tklibs/ttktheme_clearlooks/clearlooks/sbthumb-vd.gif 6333b6a387407fa53b08053e60ed520e *inst/tklibs/ttktheme_clearlooks/clearlooks/sbthumb-vn.gif 6333b6a387407fa53b08053e60ed520e *inst/tklibs/ttktheme_clearlooks/clearlooks/sbthumb-vp.gif d129deb25ca485407ecad7f8f32599b0 *inst/tklibs/ttktheme_clearlooks/clearlooks/scale-ha.gif 28d701ee397782868c64bef1fa875ab1 *inst/tklibs/ttktheme_clearlooks/clearlooks/scale-hd.gif 6e8e79b8c24c0354e3bb5dee6bd89d9d *inst/tklibs/ttktheme_clearlooks/clearlooks/scale-hn.gif 77db2b03e2a4c0953870e008c99dfffd *inst/tklibs/ttktheme_clearlooks/clearlooks/scale-va.gif 57183b960d1befd1a88fc4c9a2105e1d *inst/tklibs/ttktheme_clearlooks/clearlooks/scale-vd.gif 725b4c9f78a2af6e6a4d469854fb2752 *inst/tklibs/ttktheme_clearlooks/clearlooks/scale-vn.gif a8be3ea3cb2df6ea027334866bb66715 *inst/tklibs/ttktheme_clearlooks/clearlooks/scaletrough-h.gif bffb16fed562660a7dd3b2152f5c64a8 *inst/tklibs/ttktheme_clearlooks/clearlooks/scaletrough-v.gif aff02d69c009132c3461c624b647d81d *inst/tklibs/ttktheme_clearlooks/clearlooks/sep-h.gif 54f9ab6a8f0db4772642fccfc69e3e33 *inst/tklibs/ttktheme_clearlooks/clearlooks/sep-v.gif a505e6469a18d7fb0b4f80d8ade84463 *inst/tklibs/ttktheme_clearlooks/clearlooks/sizegrip.gif ce54df06d15e59b2596d7ca9861ba89e *inst/tklibs/ttktheme_clearlooks/clearlooks/tab-a.gif 602998a2ac62678312b364396fb63e9d *inst/tklibs/ttktheme_clearlooks/clearlooks/tab-n.gif ca577dab1608a3e8ff970ac7dd0e4d90 *inst/tklibs/ttktheme_clearlooks/clearlooks/toolbutton-a.gif e277c75aafe6d3d9fb7f345ab8f6e145 *inst/tklibs/ttktheme_clearlooks/clearlooks/toolbutton-d.gif c313606066b4bf04fecd8da070f5d84c *inst/tklibs/ttktheme_clearlooks/clearlooks/toolbutton-n.gif 63a86f14b1015d457b9d6b531b56717e *inst/tklibs/ttktheme_clearlooks/clearlooks/toolbutton-p.gif 62f41d0a48a8a1246081851576a7cd74 *inst/tklibs/ttktheme_clearlooks/clearlooks/toolbutton-pa.gif 553a822d73697d9baeb085da2945cb4e *inst/tklibs/ttktheme_clearlooks/clearlooks/tree-d.gif 59db2dfdc199f8178d13ed339b896b1a *inst/tklibs/ttktheme_clearlooks/clearlooks/tree-h.gif 8893ab46641477144abfa918a6137e0e *inst/tklibs/ttktheme_clearlooks/clearlooks/tree-n.gif 8ab8d475df0e01314b57050c272172d8 *inst/tklibs/ttktheme_clearlooks/clearlooks/tree-p.gif 7eb49f60c1a95fe267e3e948e8484d63 *inst/tklibs/ttktheme_clearlooks/clearlooks8.4.tcl 6884a12c1274af41f3f94bccc3ef5723 *inst/tklibs/ttktheme_clearlooks/clearlooks8.5.tcl 310deda54baafab619998d9d399c80df *inst/tklibs/ttktheme_clearlooks/convert_imgs.sh c2a01f15a7a99bdd90e181b8d7ee13b1 *inst/tklibs/ttktheme_clearlooks/create_imgs.py 356d788f550e7af31e1002d535a0859b *inst/tklibs/ttktheme_clearlooks/pkgIndex.tcl 7eb096e1d130bbd5f4687bc2f9a205e4 *inst/tklibs/ttktheme_clearlooks/readme.txt 52c2169b533f56380cb818b338c9940d *inst/tklibs/ttktheme_keramik/keramik.tcl 151debaa6f2e47958783d45d6f93a2de *inst/tklibs/ttktheme_keramik/keramik/arrowdown-n.gif a3fe87b25c098b5c4d17e3dcb056ed95 *inst/tklibs/ttktheme_keramik/keramik/arrowdown-p.gif d16418ff2802c2de84b2db8e7b51c7ba *inst/tklibs/ttktheme_keramik/keramik/arrowleft-n.gif 5850b48a47f4fe283c4774a40be177e8 *inst/tklibs/ttktheme_keramik/keramik/arrowleft-p.gif b2d861cd5849379751f0524701a42c26 *inst/tklibs/ttktheme_keramik/keramik/arrowright-n.gif 744ef804c4d0d3f9df7ed553537e9981 *inst/tklibs/ttktheme_keramik/keramik/arrowright-p.gif 6a92df16527362ba6a2941687d7e34df *inst/tklibs/ttktheme_keramik/keramik/arrowup-n.gif 6b770af44cf26d673e137dfdca77fb76 *inst/tklibs/ttktheme_keramik/keramik/arrowup-p.gif 4b0eb91eff4d2fe665b59327e4743d09 *inst/tklibs/ttktheme_keramik/keramik/button-d.gif bf453c09388eb387cec6b0d3ff8199dd *inst/tklibs/ttktheme_keramik/keramik/button-h.gif ba154e3bcd31dd7611cca1a762c4af76 *inst/tklibs/ttktheme_keramik/keramik/button-n.gif 6e7d116105c85a7d11a245490ca3db38 *inst/tklibs/ttktheme_keramik/keramik/button-p.gif abc39e5c22b61c278c8c8554af805311 *inst/tklibs/ttktheme_keramik/keramik/button-s.gif 691e46f2cd748ef2f81d16daca001963 *inst/tklibs/ttktheme_keramik/keramik/cbox-a.gif 9de223dc81a52cf364befd99e756a846 *inst/tklibs/ttktheme_keramik/keramik/cbox-d.gif a678f8f4b550e2f4e5f4b74f0e3d4658 *inst/tklibs/ttktheme_keramik/keramik/cbox-n.gif ce4edc3f89e94e904cd771ceffa02ed9 *inst/tklibs/ttktheme_keramik/keramik/check-c.gif 9d47c748eed5f549c19305ae076bf115 *inst/tklibs/ttktheme_keramik/keramik/check-u.gif 1a0ceb4ca670d4d5c86b02d633616c7c *inst/tklibs/ttktheme_keramik/keramik/hsb-a.gif 65ac45d255e2c86eb27bca1cb18bb77f *inst/tklibs/ttktheme_keramik/keramik/hsb-h.gif f359f2b2ba5c1c96c7e12ad3f1ae6d5e *inst/tklibs/ttktheme_keramik/keramik/hsb-n.gif b2509d87ca0ec6006a4afbd4ec22caac *inst/tklibs/ttktheme_keramik/keramik/hsb-p.gif 58e53ab88ccc79b74fa946a58fdfd6e8 *inst/tklibs/ttktheme_keramik/keramik/hsb-t.gif f7bd76f59db73489336dbfd9c27288c1 *inst/tklibs/ttktheme_keramik/keramik/hslider-n.gif 818d521852b522f87d9fff0eaaf41145 *inst/tklibs/ttktheme_keramik/keramik/hslider-t.gif ef7d5d6d6de7df634c8155405b8d0bee *inst/tklibs/ttktheme_keramik/keramik/indicator-c.gif 75f725eadcd5ae2b1dc56ba05ea21959 *inst/tklibs/ttktheme_keramik/keramik/indicator-o.gif 24acee167c366e1a0aff7157a5766a1d *inst/tklibs/ttktheme_keramik/keramik/mbut-a.gif 61a767d97f8fbedd6cf466484890a8c5 *inst/tklibs/ttktheme_keramik/keramik/mbut-arrow-n.gif 5e189dde58a01888f7172ccd2434add6 *inst/tklibs/ttktheme_keramik/keramik/mbut-d.gif e8033c6020bbd2def5bfda7a23261e53 *inst/tklibs/ttktheme_keramik/keramik/mbut-n.gif b54909af46b77f1ee4e1efe3d4dad3f7 *inst/tklibs/ttktheme_keramik/keramik/progress-h.gif 35cf92f520fe7d6977237f4e24d4d51e *inst/tklibs/ttktheme_keramik/keramik/progress-v.gif 9de5e5d31a39ea03a8dab6ac15c33b76 *inst/tklibs/ttktheme_keramik/keramik/radio-c.gif f25fe7c78b79d615a1023ddf6ef8cb03 *inst/tklibs/ttktheme_keramik/keramik/radio-u.gif e5759d6008a23170fbf6f76899254d91 *inst/tklibs/ttktheme_keramik/keramik/spinbox-a.gif e6540bc7853481b7011f1950c13f9783 *inst/tklibs/ttktheme_keramik/keramik/spindown-n.gif bcbfe599bac07f7f197477fa303b2794 *inst/tklibs/ttktheme_keramik/keramik/spindown-p.gif 6ea98594749a57833303c8d4856569f7 *inst/tklibs/ttktheme_keramik/keramik/spinup-n.gif 823455e01d4ebc87a611ab7240c29f15 *inst/tklibs/ttktheme_keramik/keramik/spinup-p.gif 091b977d943df771249e770afde16004 *inst/tklibs/ttktheme_keramik/keramik/tab-h.gif 86b4773455eee7ef51bd54732568975a *inst/tklibs/ttktheme_keramik/keramik/tab-n.gif 374adfaf533e00fad398c0112b0c29b4 *inst/tklibs/ttktheme_keramik/keramik/tab-p.gif d054e1c23fe4cb7c86ce0247612dade7 *inst/tklibs/ttktheme_keramik/keramik/tbar-a.gif 09a66f4f8141c6d46e01ba8e4c278cf8 *inst/tklibs/ttktheme_keramik/keramik/tbar-n.gif d978f5ee059c24dfe6dc7f1370c70f77 *inst/tklibs/ttktheme_keramik/keramik/tbar-p.gif bf1e465823500fe8f207dcd10a32db68 *inst/tklibs/ttktheme_keramik/keramik/tree-n.gif 906f9e15ce06056e5c6c4b9e37ce1fa0 *inst/tklibs/ttktheme_keramik/keramik/tree-p.gif ed5a0ff418ea5a428f5393345e034bf1 *inst/tklibs/ttktheme_keramik/keramik/vsb-a.gif 294127365445fdf6ce0d1b30c1b4e21c *inst/tklibs/ttktheme_keramik/keramik/vsb-h.gif 8fa646672359fd9c6f143881e41f0578 *inst/tklibs/ttktheme_keramik/keramik/vsb-n.gif fdaa21830f352ac546cad920dee12f04 *inst/tklibs/ttktheme_keramik/keramik/vsb-p.gif b5b314b77d92a02df577d561857417e7 *inst/tklibs/ttktheme_keramik/keramik/vsb-t.gif d1b20b81c25a0874ac9839bdcf316a41 *inst/tklibs/ttktheme_keramik/keramik/vslider-n.gif e78a70996339ecedd390ba166f43dcb3 *inst/tklibs/ttktheme_keramik/keramik/vslider-t.gif 1a0ceb4ca670d4d5c86b02d633616c7c *inst/tklibs/ttktheme_keramik/keramik_alt/hsb-a.gif 65ac45d255e2c86eb27bca1cb18bb77f *inst/tklibs/ttktheme_keramik/keramik_alt/hsb-h.gif ed5a0ff418ea5a428f5393345e034bf1 *inst/tklibs/ttktheme_keramik/keramik_alt/vsb-a.gif 294127365445fdf6ce0d1b30c1b4e21c *inst/tklibs/ttktheme_keramik/keramik_alt/vsb-h.gif d41aefe9c012c9d13efdc732620d7ad7 *inst/tklibs/ttktheme_keramik/pkgIndex.tcl 4d3b6b03a9bf741c51fe5da6bf9eb3ef *inst/tklibs/ttktheme_plastik/pkgIndex.tcl d921964802cd9298108a50ac7528158e *inst/tklibs/ttktheme_plastik/plastik.tcl 5f9ab7f87e4457d6d3d680f6dbb8ee7c *inst/tklibs/ttktheme_plastik/plastik/arrow-d.gif a6ed1040b421cc62004a58b7fecf0940 *inst/tklibs/ttktheme_plastik/plastik/arrowdown-n.gif 42ca714678608c49828b49d968430419 *inst/tklibs/ttktheme_plastik/plastik/arrowdown-p.gif 6e54de9dce418fe16a71b4e1d02d0e2b *inst/tklibs/ttktheme_plastik/plastik/arrowleft-n.gif cc944c0eb1031708e44af4e13dabcd1c *inst/tklibs/ttktheme_plastik/plastik/arrowleft-p.gif 3645ef01e46da179be75aab4721fa10c *inst/tklibs/ttktheme_plastik/plastik/arrowright-n.gif 3360ad5668cc9737e9891a235cfb4416 *inst/tklibs/ttktheme_plastik/plastik/arrowright-p.gif 3741fc63a91bfe210ea66142a6b2774b *inst/tklibs/ttktheme_plastik/plastik/arrowup-n.gif d9766b0205c0e57993943093a190eb06 *inst/tklibs/ttktheme_plastik/plastik/arrowup-p.gif ee0662329970e326972b7eb05a4b7197 *inst/tklibs/ttktheme_plastik/plastik/border.gif 4786e7a91c526cd1ad4c3718cfd6142c *inst/tklibs/ttktheme_plastik/plastik/button-h.gif e652bd7fa0faacd15af938a344c1b2d6 *inst/tklibs/ttktheme_plastik/plastik/button-n.gif 631f3cb449426cd4e7d22b7a1b7eee99 *inst/tklibs/ttktheme_plastik/plastik/button-p.gif 0c478dc4f715e09417132df50155d618 *inst/tklibs/ttktheme_plastik/plastik/check-hc.gif 4fdbcd482c3d8f476bf0bf9366b264c1 *inst/tklibs/ttktheme_plastik/plastik/check-hu.gif 4c4681c4463a131e5cfaf0b0b47bc893 *inst/tklibs/ttktheme_plastik/plastik/check-nc.gif 2b7c40867a26daccbd83b8d92660eec5 *inst/tklibs/ttktheme_plastik/plastik/check-nu.gif b89473a19c86c733e62828f8d4ab5881 *inst/tklibs/ttktheme_plastik/plastik/check-pc.gif 74abb8048743e634de760ea76ed8b688 *inst/tklibs/ttktheme_plastik/plastik/combo-a.gif b6357a2cc365ac77637531304b12b4be *inst/tklibs/ttktheme_plastik/plastik/combo-f.gif 28f652313716d16bee7053cf65ed6628 *inst/tklibs/ttktheme_plastik/plastik/combo-fa.gif 36065635b172f0de481b7ec60452ec46 *inst/tklibs/ttktheme_plastik/plastik/combo-n.gif f79b191efef9ef7ab4a0287b1fcbc714 *inst/tklibs/ttktheme_plastik/plastik/combo-r.gif ad83b9a2b02e9c59657dcadd4bb0f2cc *inst/tklibs/ttktheme_plastik/plastik/combo-ra.gif e5cc1a8e64ea615ffcd2c2c3f1686331 *inst/tklibs/ttktheme_plastik/plastik/entry-f.gif e520c96dd674cae37fe60ca8a38c692b *inst/tklibs/ttktheme_plastik/plastik/entry-n.gif adefce1544ed1942a7de1fe1a257dad5 *inst/tklibs/ttktheme_plastik/plastik/hprogress-b.gif 5d87594c440870e2899b5fb0e905f4f3 *inst/tklibs/ttktheme_plastik/plastik/hprogress-t.gif e163baa304e4c12e77720e72eae38d94 *inst/tklibs/ttktheme_plastik/plastik/hsb-g.gif f7a0fa7a112035ef0514ddcb78e56a68 *inst/tklibs/ttktheme_plastik/plastik/hsb-n.gif f28eb5431b2d0ba72c2a20ccd145cc01 *inst/tklibs/ttktheme_plastik/plastik/hsb-t.gif 460dfec57b8ad0d4fa6ddc778c770647 *inst/tklibs/ttktheme_plastik/plastik/hslider-n.gif 2bd04e8eb56f2b564d794d90cfb4067f *inst/tklibs/ttktheme_plastik/plastik/hslider-t.gif 2132a292085187373907209fc0185aeb *inst/tklibs/ttktheme_plastik/plastik/notebook-c.gif 6936b48c4c60e65096f287beca05930a *inst/tklibs/ttktheme_plastik/plastik/notebook-ta.gif 97b9a5c6252a7c0542aa4ef9d0e4c2cf *inst/tklibs/ttktheme_plastik/plastik/notebook-tn.gif c987a6cf39f352124cdf5c38cb596cb1 *inst/tklibs/ttktheme_plastik/plastik/notebook-ts.gif 6bcbfb3d4c08b63a5246c451cc50fdf0 *inst/tklibs/ttktheme_plastik/plastik/radio-hc.gif 0013dbd76afa3187a0d320ac3436c82e *inst/tklibs/ttktheme_plastik/plastik/radio-hu.gif 53c8cdfdf7f971b44fb2ce058928b4d4 *inst/tklibs/ttktheme_plastik/plastik/radio-nc.gif 3109f7dc0e82fceec368fce1ddd91f82 *inst/tklibs/ttktheme_plastik/plastik/radio-nu.gif e92df62d52d58d0c8c1b1e16d4ca133e *inst/tklibs/ttktheme_plastik/plastik/radio-pc.gif 2758d85e9696e3041c8e2bcdf6261b23 *inst/tklibs/ttktheme_plastik/plastik/spinbox-f.gif 8ebeecf4e7b9de5e9af833927699f9c8 *inst/tklibs/ttktheme_plastik/plastik/spinbox-n.gif f6958168c7b3d4154cdfb57056e370d6 *inst/tklibs/ttktheme_plastik/plastik/spinbut-a.gif dc26b3b74f8df1937c311e99132ceead *inst/tklibs/ttktheme_plastik/plastik/spinbut-n.gif a9a27bbff3368ec8007ea91cc1fe93f6 *inst/tklibs/ttktheme_plastik/plastik/spindown-d.gif 06c3dd2630a3decec5168a0ac36ccb88 *inst/tklibs/ttktheme_plastik/plastik/spindown-n.gif b5a4ea0d6c7e1a1e3c0f074005c3d1f8 *inst/tklibs/ttktheme_plastik/plastik/spindown-p.gif 10485149718030e1fc1c5b6dcfa4f869 *inst/tklibs/ttktheme_plastik/plastik/spinup-d.gif 56a552501866ae8e40a5cdc76c076368 *inst/tklibs/ttktheme_plastik/plastik/spinup-n.gif 3c7c62a03b95e92ac7a9f26674c8c239 *inst/tklibs/ttktheme_plastik/plastik/spinup-p.gif 36a87b8b20d8c115233acba5b6b2f6a5 *inst/tklibs/ttktheme_plastik/plastik/tbutton-h.gif 3fca28f69823c80ee5a8f6fb3307dba5 *inst/tklibs/ttktheme_plastik/plastik/tbutton-n.gif 8871edd562980a1f3867d8b1327999a9 *inst/tklibs/ttktheme_plastik/plastik/tbutton-p.gif ebf719eee2111586de1b0402c0d203f5 *inst/tklibs/ttktheme_plastik/plastik/tree-n.gif 3b2a314d747763bea410cfe4ffbd9ed2 *inst/tklibs/ttktheme_plastik/plastik/tree-p.gif c007d0beeb5a24038c878efb9c4bce97 *inst/tklibs/ttktheme_plastik/plastik/vprogress-b.gif c5e3a6cd9077dd5254262927cc05105b *inst/tklibs/ttktheme_plastik/plastik/vsb-g.gif 804efb2acbbc93f8c0e348d2fa2784f5 *inst/tklibs/ttktheme_plastik/plastik/vsb-n.gif b262f94c42f4ebc8289c87dde4c5e3ae *inst/tklibs/ttktheme_plastik/plastik/vsb-t.gif 8c01b2fb6aab559351ef0ffee60d759b *inst/tklibs/ttktheme_plastik/plastik/vslider-n.gif 70c031e267debc65929c3daec7c36825 *inst/tklibs/ttktheme_plastik/plastik/vslider-t.gif b6373fe1abe8a6b173ebfe5086bdda37 *inst/tklibs/ttktheme_radiance/pkgIndex.tcl 553edd9d40e74257db6efabbd35fe5b5 *inst/tklibs/ttktheme_radiance/radiance/arrowdown-a.gif ef7a1adfc0eb205761560d208124a1f0 *inst/tklibs/ttktheme_radiance/radiance/arrowdown-d.gif b4be827ed87b0f53b4d628a3d9caa074 *inst/tklibs/ttktheme_radiance/radiance/arrowdown-n.gif 3c19022a96ed72be3f3e976fdbc0e86e *inst/tklibs/ttktheme_radiance/radiance/arrowdown-p.gif 678b2f9c085b9900ece976b6cbff56ab *inst/tklibs/ttktheme_radiance/radiance/arrowleft-a.gif fa85ca7a2eb58e771ccfa6f476e5f171 *inst/tklibs/ttktheme_radiance/radiance/arrowleft-d.gif 74feabec69e49f4c1599b2f08e1f8f1e *inst/tklibs/ttktheme_radiance/radiance/arrowleft-n.gif e83913445dc59929363d075e522abb18 *inst/tklibs/ttktheme_radiance/radiance/arrowleft-p.gif 33c95aed5b3cd351579969ab0420a592 *inst/tklibs/ttktheme_radiance/radiance/arrowright-a.gif 7e3e510409fedae2c32d2d5826ee4542 *inst/tklibs/ttktheme_radiance/radiance/arrowright-d.gif 5dd23cfa4acd10b8ed366607e46dd9a6 *inst/tklibs/ttktheme_radiance/radiance/arrowright-n.gif 37f00b1cf03f3da6c9cb5da0325028e5 *inst/tklibs/ttktheme_radiance/radiance/arrowright-p.gif 9d5d604c630255214551b4193adea48e *inst/tklibs/ttktheme_radiance/radiance/arrowup-a.gif 60c2e9e78db0949d43e7ab515b0f1158 *inst/tklibs/ttktheme_radiance/radiance/arrowup-d.gif be840756ae7f9737d34c3b3f0e0fa0aa *inst/tklibs/ttktheme_radiance/radiance/arrowup-n.gif b53b03f059f760be28a7c6c52b09b8e4 *inst/tklibs/ttktheme_radiance/radiance/arrowup-p.gif b1a1bad9caa9a8ea7e6fb57b7977bd6f *inst/tklibs/ttktheme_radiance/radiance/blank.gif be415e3e9fe651b9a577ed1a19a612db *inst/tklibs/ttktheme_radiance/radiance/button-a.gif 5b9b8978c84691fba12b30543b73815e *inst/tklibs/ttktheme_radiance/radiance/button-d.gif ca8cbf2091982e40cba7fadbfadda334 *inst/tklibs/ttktheme_radiance/radiance/button-n.gif 66174e4c1376a747de567af30e3b3fac *inst/tklibs/ttktheme_radiance/radiance/button-p.gif 7f24a9763f067eec1d8edf3581f5ecc3 *inst/tklibs/ttktheme_radiance/radiance/button-s.gif cad6708e8dcaa0c2ab42779cecec1395 *inst/tklibs/ttktheme_radiance/radiance/button-sa.gif a8b5d93c3eb7cd247357cce05c5e03d1 *inst/tklibs/ttktheme_radiance/radiance/check-dc.gif 4995d0a9cda8186a98fb1290b91984fa *inst/tklibs/ttktheme_radiance/radiance/check-du.gif ec273a2ce4c408ec528677eabacc6707 *inst/tklibs/ttktheme_radiance/radiance/check-nc.gif 6cd818830c1e217e318eca60b18059da *inst/tklibs/ttktheme_radiance/radiance/check-nu.gif 8e9ab52aee6f9711bfd6703a43995705 *inst/tklibs/ttktheme_radiance/radiance/combo-n.gif 6edd969783caeaca4106c54b86d4fc48 *inst/tklibs/ttktheme_radiance/radiance/combo-ra.gif 33af2d10d5f50c05e5ff90f362d4e59b *inst/tklibs/ttktheme_radiance/radiance/combo-rd.gif 356482ddcf5f7c74b809e38e99d4c545 *inst/tklibs/ttktheme_radiance/radiance/combo-rf.gif 62c3561b2c1c5808d9ca8c166b1894d0 *inst/tklibs/ttktheme_radiance/radiance/combo-rn.gif b4e6b494e3ac99233a5998f7c10fe4c0 *inst/tklibs/ttktheme_radiance/radiance/combo-rp.gif 87784c1508c4f779c478f5f4f5cedd22 *inst/tklibs/ttktheme_radiance/radiance/comboarrow-a.gif 66a532e6396c5f529a21c09cb6731a15 *inst/tklibs/ttktheme_radiance/radiance/comboarrow-d.gif 89d681f87da3f7bfd547360683928d1f *inst/tklibs/ttktheme_radiance/radiance/comboarrow-n.gif 3443a704d68ee5433e1711c801254453 *inst/tklibs/ttktheme_radiance/radiance/comboarrow-p.gif b6f6f0cc880c1ba868378a3062db824c *inst/tklibs/ttktheme_radiance/radiance/progress-h.gif b4f29c5d62714fdc570f84977043fe1b *inst/tklibs/ttktheme_radiance/radiance/progress-v.gif 1efeb186cf420e471ba708ed3934f1eb *inst/tklibs/ttktheme_radiance/radiance/radio-dc.gif b0a619167547d7db53fc310e212b929a *inst/tklibs/ttktheme_radiance/radiance/radio-du.gif 4810c540bc42e1f5c8fc9769723a4122 *inst/tklibs/ttktheme_radiance/radiance/radio-nc.gif 5eac9169d48880d402a858d8cd476316 *inst/tklibs/ttktheme_radiance/radiance/radio-nu.gif 66476e60721aafd4bb1d9f8ccb46145d *inst/tklibs/ttktheme_radiance/radiance/sbthumb-ha.gif 849ef962dd19ed70cbb0245427b2ac54 *inst/tklibs/ttktheme_radiance/radiance/sbthumb-hd.gif 777be1105c6f9202517a247d4d5337b9 *inst/tklibs/ttktheme_radiance/radiance/sbthumb-hn.gif 777be1105c6f9202517a247d4d5337b9 *inst/tklibs/ttktheme_radiance/radiance/sbthumb-hp.gif 971515ced4b094b666fe74f8c7ad5fa5 *inst/tklibs/ttktheme_radiance/radiance/sbthumb-va.gif 713ae6f0be922f97ce223d95b446d026 *inst/tklibs/ttktheme_radiance/radiance/sbthumb-vd.gif c04c4ed4f527cc6e8671948ffd498daa *inst/tklibs/ttktheme_radiance/radiance/sbthumb-vn.gif c04c4ed4f527cc6e8671948ffd498daa *inst/tklibs/ttktheme_radiance/radiance/sbthumb-vp.gif a05432b941de4b3b369d128ef873deeb *inst/tklibs/ttktheme_radiance/radiance/scale-ha.gif 5678073a610c8e102fe069643322a6cb *inst/tklibs/ttktheme_radiance/radiance/scale-hd.gif 8e067546b2fb1ba0f237e020e741d0d6 *inst/tklibs/ttktheme_radiance/radiance/scale-hn.gif f77a8ec759c2de04cd3200250079ffae *inst/tklibs/ttktheme_radiance/radiance/scale-va.gif a7e265674273cc60da9354219a669662 *inst/tklibs/ttktheme_radiance/radiance/scale-vd.gif 0d03f2bb66621204323e15e6fc1ad22d *inst/tklibs/ttktheme_radiance/radiance/scale-vn.gif 1881df75d0ae7e3900b4e5bb8b3b851d *inst/tklibs/ttktheme_radiance/radiance/scaletrough-h.gif 0b9ccf7e6fe92141282f0c0b02a89791 *inst/tklibs/ttktheme_radiance/radiance/scaletrough-v.gif 03928631a76df0cc12d2e126ea85456d *inst/tklibs/ttktheme_radiance/radiance/sep-h.gif 0d66e282838694de694f7b80d50f21d0 *inst/tklibs/ttktheme_radiance/radiance/sep-v.gif b101a87bdd60719b7b1226d24d885338 *inst/tklibs/ttktheme_radiance/radiance/sizegrip.gif a2b6c9c63f271abc4585f43ed2bf639d *inst/tklibs/ttktheme_radiance/radiance/tab-a.gif d5183ebc15d4254cb00a6857792eb501 *inst/tklibs/ttktheme_radiance/radiance/tab-n.gif 98314bdd8bd5f76b72dc96fdead138a0 *inst/tklibs/ttktheme_radiance/radiance/toolbutton-a.gif 58ade249104d4d44898f3d922f07ab34 *inst/tklibs/ttktheme_radiance/radiance/toolbutton-d.gif d953bcf3add0b7e7cff6d582bf9be899 *inst/tklibs/ttktheme_radiance/radiance/toolbutton-n.gif d93ecc400800d0970c01a7878c8bdb7e *inst/tklibs/ttktheme_radiance/radiance/toolbutton-p.gif 52895272d3c8ff2e8b216519457fcfbc *inst/tklibs/ttktheme_radiance/radiance/toolbutton-pa.gif f691dca2b9b723772e1e63ac608ee7ef *inst/tklibs/ttktheme_radiance/radiance/tree-d.gif 86355bcda84fc953c8742c1188c20e3d *inst/tklibs/ttktheme_radiance/radiance/tree-h.gif d5268b429cc48d73f97d70cad528ec5c *inst/tklibs/ttktheme_radiance/radiance/tree-n.gif 148bdded7e1b71fb30e2a8a647d5dc25 *inst/tklibs/ttktheme_radiance/radiance/tree-p.gif b93ac611a29400e14452b4e13baef796 *inst/tklibs/ttktheme_radiance/radiance8.4.tcl 968716affa7a9eb09f5916d3c09481ed *inst/tklibs/ttktheme_radiance/radiance8.5.tcl 59585c71dde258d29ceadc5732eed857 *inst/tklibs/widget3.2/ChangeLog f3cf353fd0a9bfa2b556d5dc67de0183 *inst/tklibs/widget3.2/arrowb.tcl 391a32081e079a4cc842b59f37771c64 *inst/tklibs/widget3.2/calendar.tcl 22ba5eb474f8a0114c7a63636bcd91a3 *inst/tklibs/widget3.2/dateentry.tcl 51b580d374f4b2ce40d185055423cb05 *inst/tklibs/widget3.2/dialog.tcl f8b1e738a42aa60334112d62a0dd7e90 *inst/tklibs/widget3.2/mentry.tcl d46e0e5b64af852f5d56b97d5f91cf7d *inst/tklibs/widget3.2/panelframe.tcl ae6556ad7f9dfdd997a416e3b1d002cc *inst/tklibs/widget3.2/pkgIndex.tcl 12ac11ae43f11a1c0d35ffd6ff182b6c *inst/tklibs/widget3.2/ruler.tcl cd22ca9f4a82743ec8a36c767589514d *inst/tklibs/widget3.2/scrollw.tcl 046cffd72c7945d325f1dd0e9d69a293 *inst/tklibs/widget3.2/statusbar.tcl ca4f5c92a66a75027ac46a795bf0164c *inst/tklibs/widget3.2/stext.tcl e87349dcec2f1d163dead9b47d5b654b *inst/tklibs/widget3.2/superframe.tcl 5d33cc74dac571be8de6d9bfb9a4a8c1 *inst/tklibs/widget3.2/toolbar.tcl 32f1e36f42ad96cdf536c07ee99b0927 *inst/tklibs/widget3.2/widget.man a5865978301bcd8bee6b386333814f3e *inst/tklibs/widget3.2/widget.tcl 02f5b16d1ed3f66fad8d89c77156389b *inst/tklibs/widget3.2/widget_calendar.man b529775c7c64e4fec43adb30986e4aac *inst/tklibs/widget3.2/widget_dateentry.man bfba5f7b16e22d0b563e049aa381371e *inst/tklibs/widget3.2/widget_toolbar.man 4798addd851eb5eba081a186caa0a0aa *man/setLanguage.Rd 5bd35c7ac1a41f224acc5a44bc9433ca *man/tclTask.Rd 82102454424dec49bdeaa181face0a47 *man/tclVarFun.Rd d10482c57ee29e0824ab003993543355 *man/tcltk2-package.Rd 908a2e623a9dc121d3d00817f6bb1ba4 *man/tk2commands.Rd 984aa7a01c86093bf1525204b979ca30 *man/tk2dde.Rd 8f9e18115eb228e3e7c947d1e0148a1e *man/tk2dialogfonts.Rd 5d086bfd2819aece4bb3fd7923624e64 *man/tk2edit.Rd 19bfd051f2389669ef3fd942d4168dde *man/tk2fonts.Rd b874868f072a1d3e158f49c734f3f69d *man/tk2ico.Rd 370bc2dfaf13fbeed84f6529475f0879 *man/tk2methods.Rd e7a622e2775cc2afebdf0516454217ab *man/tk2reg.Rd de11ebde5bb5a547c809cacaff2aeb0e *man/tk2swaplist.Rd c6831745739013163b1b1272502c8595 *man/tk2tip.Rd 46d221bd9b07f137da0f8a6416363f01 *man/tk2widgets.Rd 07c27af545a7fb14e1f17381b045f35a *po/R-de.po c01942019b0f94f5ad0942566f712612 *po/R-fr.po 8d2e80891ce0c30ea4b62623a68c3570 *po/R-tcltk2.pot 75444ed93db372522253766eb192bc51 *vignettes/tcltk2.Rmd tcltk2/po/0000755000176200001440000000000014656355210012102 5ustar liggesuserstcltk2/po/R-tcltk2.pot0000755000176200001440000000504314656355210014235 0ustar liggesusersmsgid "" msgstr "" "Project-Id-Version: R 2.3.0\n" "Report-Msgid-Bugs-To: bugs@r-project.org\n" "POT-Creation-Date: 2007-01-03 09:55\n" "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" "Last-Translator: FULL NAME \n" "Language-Team: LANGUAGE \n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=CHARSET\n" "Content-Transfer-Encoding: 8bit\n" msgid "'f' must be a function!" msgstr "" msgid "The function used cannot (yet) have arguments!" msgstr "" msgid "'name' must be a character string!" msgstr "" msgid "'name' must be a character!" msgstr "" msgid "Error when getting the value in the '%s' Tcl variable" msgstr "" msgid "Error when changing the value of the '%s' Tcl variable" msgstr "" msgid "This is a Windows-specific function!" msgstr "" msgid "This version of R cannot use Tcl/Tk!" msgstr "" msgid "Unable to find the 'dde' Tcl/tk package!" msgstr "" msgid "'topic' must be a non null character string!" msgstr "" msgid "'service', 'topic' and 'command' must be character strings!" msgstr "" msgid "'service' and 'topic' must be character strings!" msgstr "" msgid "'item' must be character strings!" msgstr "" msgid "'iconfile' must be of length one!" msgstr "" msgid "File '%s' not found!" msgstr "" msgid "Error creating the icon resource; probably wrong 'iconfile'" msgstr "" msgid "'icon' is not a \"tclIcon\" object!" msgstr "" msgid "Error getting the icon handle for a \"tclIcon\" object!" msgstr "" msgid "Impossible to retrieve icon resource information!" msgstr "" msgid "'file' must be of length one!" msgstr "" msgid "'res' must be of length one!" msgstr "" msgid "Unable to load the icon resource, 'file' or 'res' is wrong!" msgstr "" msgid "'value' must be numeric and of length one!" msgstr "" msgid "Error while changing default position of the icon!" msgstr "" msgid "'win' is not a \"tkwin\" object, or an integer (Window handle)!" msgstr "" msgid "'pos' must be numeric and of length one, or NULL!" msgstr "" msgid "'leftmenu' must be a \"tkwin\" object or NULL!" msgstr "" msgid "'rightmenu' must be a \"tkwin\" object or NULL!" msgstr "" msgid "Error while creating the callback for this icon!" msgstr "" msgid "Error getting the text associated with an icon!" msgstr "" msgid "'value' must not be empty or NULL!" msgstr "" msgid "Error while changing text of the icon!" msgstr "" msgid "Unable to find the 'registry' Tcl/tk package!" msgstr "" msgid "Unrecognized 'type'!" msgstr "" tcltk2/po/R-fr.po0000755000176200001440000001046214656355210013256 0ustar liggesusersmsgid "" msgstr "" "Project-Id-Version: tcltk2\n" "POT-Creation-Date: \n" "PO-Revision-Date: 2007-01-03 09:47+0100\n" "Last-Translator: Philippe Grosjean \n" "Language-Team: Ph. Grosjean \n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=iso-8859-1\n" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=2; plural=(n > 1);\n" "X-Poedit-Language: French\n" "X-Poedit-SourceCharset: iso-8859-1\n" msgid "'f' must be a function!" msgstr "'f' doit être une fonction !" msgid "The function used cannot (yet) have arguments!" msgstr "La fonction utilisée ne peut pas (encore) avoir d'arguments !" msgid "'name' must be a character string!" msgstr "'name' doit être une chaîne de caractères !" msgid "'name' must be a character!" msgstr "'name' doit être une chaîne de caractères !" msgid "Error when getting the value in the '%s' Tcl variable" msgstr "Erreur lors de la récupération de la valeur contenue dans la variable Tcl '%s'" msgid "Error when changing the value of the '%s' Tcl variable" msgstr "Erreur lors de la modification de la valeur contenue dans la variable Tcl '%s'" msgid "This is a Windows-specific function!" msgstr "Ceci est une fonction spécifique à Windows !" msgid "This version of R cannot use Tcl/Tk!" msgstr "Cette version de R n'utilise pas Tcl/Tk !" msgid "Unable to find the 'dde' Tcl/tk package!" msgstr "Impossible de trouver le package Tcl/Tk 'dde' !" msgid "'topic' must be a non null character string!" msgstr "'topic' doit être une chaîne de caractères non nulle !" msgid "'service', 'topic' and 'command' must be character strings!" msgstr "'service', 'topic' et 'command' doivent être des chaînes de caractères !" msgid "'service' and 'topic' must be character strings!" msgstr "'service' et 'topic' doivent être des chaînes de caractères !" msgid "'item' must be character strings!" msgstr "'item' doit contenir des chaînes de caractères !" msgid "'iconfile' must be of length one!" msgstr "'iconfile' doit être de longueur unitaire !" msgid "File '%s' not found!" msgstr "Fichier '%s' introuvable !" msgid "Error creating the icon resource; probably wrong 'iconfile'" msgstr "Erreur lors de la création de la ressource d'icône ; 'iconfile' est probablement corrompu ou incorrect " msgid "'icon' is not a \"tclIcon\" object!" msgstr "'icon' n'est pas un objet \"tclIcon\" !" msgid "Error getting the icon handle for a \"tclIcon\" object!" msgstr "Erreur lors de la récupération du pointeur d'icône pour un objet \"tclIcon\" !" msgid "Impossible to retrieve icon resource information!" msgstr "Impossible de récupérer l'information de la ressource d'icône !" msgid "'file' must be of length one!" msgstr "'file' doit être de longueur unitaire !" msgid "'res' must be of length one!" msgstr "'res' doit être de longueur unitaire !" msgid "Unable to load the icon resource, 'file' or 'res' is wrong!" msgstr "Incapable de charger la ressource d'icône, 'file' ou 'res' est erronné !" msgid "'value' must be numeric and of length one!" msgstr "'value' doit être numérique et de longueur unitaire !" msgid "Error while changing default position of the icon!" msgstr "Erreur lors du changement de la position par défaut de l'icône !" msgid "'win' is not a \"tkwin\" object, or an integer (Window handle)!" msgstr "'win' n'est pas un objet \"tkwin\", ou un entier (handle de fenêtre) !" msgid "'pos' must be numeric and of length one, or NULL!" msgstr "'pos' doit être numérique et de longueur unitaire, ou NULL !" msgid "'leftmenu' must be a \"tkwin\" object or NULL!" msgstr "'leftmenu' doit être un objet \"tkwin\" ou NULL !" msgid "'rightmenu' must be a \"tkwin\" object or NULL!" msgstr "'rightmenu' doit être un objet \"tkwin\" ou NULL !" msgid "Error while creating the callback for this icon!" msgstr "Erreur lors de la création du callback pour cette icône !" msgid "Error getting the text associated with an icon!" msgstr "Erreur lors de la lecture du texte associé à cette icône !" msgid "'value' must not be empty or NULL!" msgstr "'value' ne peut être vide ou NULL !" msgid "Error while changing text of the icon!" msgstr "Erreur lors de la modification du texte associé à cette icône !" msgid "Unable to find the 'registry' Tcl/tk package!" msgstr "Incapable de trouver la package Tcl/Tk 'registry' !" msgid "Unrecognized 'type'!" msgstr "'type' non reconnu !" tcltk2/po/R-de.po0000644000176200001440000001042214656355210013230 0ustar liggesusers# Translation of r-cran-tcltk2 to German. # Copyright (C) 2009 - 2013 Philippe Grosjean. # This file is distributed under the same license as the r-cran-tcltk2 package. # Chris Leick , 2017 # msgid "" msgstr "" "Project-Id-Version: R 3.6.2\n" "Report-Msgid-Bugs-To: bugs@r-project.org\n" "POT-Creation-Date: 2007-01-03 09:55\n" "PO-Revision-Date: 2020-01-06 15:35+0100\n" "Last-Translator: Chris Leick \n" "Language-Team: German \n" "Language: de\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" msgid "'f' must be a function!" msgstr "'f' muss eine Funktion sein!" msgid "The function used cannot (yet) have arguments!" msgstr "Die benutzte Funktion kann (noch) keine Argumente haben!" msgid "'name' must be a character string!" msgstr "'name' muss eine Zeichenkette sein!" msgid "'name' must be a character!" msgstr "'name' muss ein Zeichen sein!" msgid "Error when getting the value in the '%s' Tcl variable" msgstr "Fehler beim Holen des Werts in der Tcl-Variable »%s«" msgid "Error when changing the value of the '%s' Tcl variable" msgstr "Fehler beim Ändern des Werts der Tcl-Variable »%s«" msgid "This is a Windows-specific function!" msgstr "Dies ist eine Windows-spezifische Funktion!" msgid "This version of R cannot use Tcl/Tk!" msgstr "Diese Version von R kann Tcl/Tk nicht benutzen!" msgid "Unable to find the 'dde' Tcl/tk package!" msgstr "Das Tcl/Tk-Paket 'dde' konnte nicht gefunden werden!" msgid "'topic' must be a non null character string!" msgstr "'topic' muss eine Zeichenkette ungleich Null sein!" msgid "'service', 'topic' and 'command' must be character strings!" msgstr "'service', 'topic' und »command« müssen Zeichenketten sein!" msgid "'service' and 'topic' must be character strings!" msgstr "'service' und 'topic' müssen Zeichenketten sein!" msgid "'item' must be character strings!" msgstr "'item' müssen Zeichenketten sein!" msgid "'iconfile' must be of length one!" msgstr "'iconfile' muss die Länge eins haben!" msgid "File '%s' not found!" msgstr "Datei '%s' nicht gefunden!" msgid "Error creating the icon resource; probably wrong 'iconfile'" msgstr "Fehler beim Erstellen der Icon-Quelle; möglicherweise falsches 'iconfile'" msgid "'icon' is not a \"tclIcon\" object!" msgstr "'icon' ist kein \"tclIcon\"-Objekt!" msgid "Error getting the icon handle for a \"tclIcon\" object!" msgstr "Fehler beim Holen eines Icon-Handles für ein \"tclIcon\"-Objekt!" msgid "Impossible to retrieve icon resource information!" msgstr "Fehler beim Abrufen der Icon-Ressourceinformationen!" msgid "'file' must be of length one!" msgstr "'file' muss die Länge eins haben!" msgid "'res' must be of length one!" msgstr "'res' muss die Länge eins haben!" msgid "Unable to load the icon resource, 'file' or 'res' is wrong!" msgstr "Icon-Ressource kann nicht geladen werden 'file' oder 'res' ist falsch!" msgid "'value' must be numeric and of length one!" msgstr "'value' muss numerisch sein und die Länge eins haben!" msgid "Error while changing default position of the icon!" msgstr "Fehler beim Ändern der Standardposition des Icons!" msgid "'win' is not a \"tkwin\" object, or an integer (Window handle)!" msgstr "'win' ist kein \"tkwin\"-Objekt oder eine Ganzzahl (Fenster-Handle)!" msgid "'pos' must be numeric and of length one, or NULL!" msgstr "'pos' muss numerisch sein und die Länge eins haben oder NULL sein!" msgid "'leftmenu' must be a \"tkwin\" object or NULL!" msgstr "'leftmenu' muss ein »tkwin«-Objekt oder NULL sein!" msgid "'rightmenu' must be a \"tkwin\" object or NULL!" msgstr "'rightmenu' muss ein »tkwin«-Objekt oder NULL sein!" msgid "Error while creating the callback for this icon!" msgstr "Fehler beim Erzeugen der Rückruffunktion für dieses Icon!" msgid "Error getting the text associated with an icon!" msgstr "Fehler beim Holen des zu diesem Icon gehörenden Textes!" msgid "'value' must not be empty or NULL!" msgstr "'value' darf nicht leer oder NULL sein!" msgid "Error while changing text of the icon!" msgstr "Fehler beim Ändern des Icon-Textes!" msgid "Unable to find the 'registry' Tcl/tk package!" msgstr "Das Tcl/Tk-Paket 'registry' konnte nicht gefunden werden!" msgid "Unrecognized 'type'!" msgstr "Unbekannter 'type'!" tcltk2/R/0000755000176200001440000000000015017041713011655 5ustar liggesuserstcltk2/R/tk2reg.R0000755000176200001440000002346315017045233013212 0ustar liggesusers# TODO: # - use a try for tk2reg.get() # - Change double call for a try() for tk2reg.keys(), tk2reg.type() # and tk2reg.values() # - Add "none to the type of supported formats? ### TODO: implement ::ico::getIconByName, ::ico::getFileIcon & ::ico::writeIcon ### TODO: gif files are acceptable too for tk2ico.set(), example: ### Image <- tclVar() ### tcl("image", "create", "photo", Image, file = "myfile.gif") ### tcl("wm", "iconphoto", tt, Image) instead of tk2ico.set #' Manipulate the registry under Windows #' #' These functions access the Windows registry in a secure way (most errors #' are handled gracefully), and ensures correct conversion back and forth #' for atomic strings ('sz' and 'expand\\\\_') and numbers ('dword' and #' 'dword\\\\_big\\\\_endian'), and for vectors of strings ('multi\\\\_sz'). #' #' @param keyname The name of the key. #' @param valuename A value in this key. #' @param data The data to place in this value. #' @param type The type of value in the registry. By default, it is 'sz', that #' is, an atomic string. #' #' @return #' Functions that should return registry value(s) or key(s) return them in a #' character string, or they return `NA` if the key/value is not found in the #' registry. #' #' [tk2reg.broadcast()], [tk2reg.delete()], [tk2reg.deletekey()], #' [tk2reg.set()] and [tk2reg.setkey()] return `TRUE` in case of success and #' `FALSE` otherwise. #' #' [tk2reg.get()] should handle correctly the types 'sz', 'expand\\\\_sz' and #' multi\\\\_sz' (note that 'expand\\\\_sz' string is NOT expanded!), as well as #' dword' and 'dword\\\\_big\\\\_endian' that are converted into numeric values. #' Other types are not converted and the Tcl expression is returned ('objTcl' #' class) untransformed. #' #' [tk2reg.set()] currently works with 'sz', 'expand\\\\_sz', 'multi\\\\_sz', #' dword' and 'dword\\\\_big\\\\_endian' types. A couple of other types are #' accepted by the function... but they are not tested ('binary', 'link', #' resource\\\\_list'). #' #' @note #' For Windows only. These functions issue an error when they are called #' under other platforms. Take care while manipulating the Windows registry! #' You can easily lock the system completely, if you delete important items, #' especially if you are logged as administrator on your computer. Make a backup #' of your registry first before experimenting with these function!!! #' #' @export #' @rdname tk2reg #' @author Philippe Grosjean #' @seealso [tk2dde.exec()], [tk2ico.create()] #' @keywords utilities #' #' @examples #' \dontrun{ #' # These cannot be run by examples() but should be OK when pasted #' # into an interactive R session with the tcltk package loaded #' #' ### Examples of tk2reg - registry manipulation under Windows #' # Rem: HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, #' # HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, HKEY_DYN_DATA #' Rkey <- "HKEY_CURRENT_USER\\\\Software\\\\R-core\\\\R" # The R key #' Rkey <- paste(Rkey, "\\\\", R.version$major, ".", R.version$minor, sep = "") #' Rsubkey <- paste(Rkey, "subkey", sep = "\\\\") # A subkey #' #' # Get all subkeys for Software in the local machine #' tk2reg.keys("HKEY_LOCAL_MACHINE\\\\Software") #' #' # Get all names in the R key #' tk2reg.values(Rkey) #' #' # Get the path for the current R version #' tk2reg.get(Rkey, "InstallPath") #' #' # Create a subkey (explore the registry with regedit.exe to see it) #' tk2reg.setkey(Rsubkey) #' # Add a couple of keys in it #' tk2reg.set(Rsubkey, "test", "a key added in the registry!", type = "sz") #' tk2reg.set(Rsubkey, "test exp", "\%SystemRoot\%\\\\system32", type = "expand_sz") #' tk2reg.set(Rsubkey, "test multi", LETTERS[1:5], type = "multi_sz") #' tk2reg.set(Rsubkey, "test dword", 1024, type = "dword") #' tk2reg.set(Rsubkey, "test big end", 1024, type = "dword_big_endian") #' #' # Get the type of a value #' tk2reg.type(Rsubkey, "test") #' tk2reg.type(Rsubkey, "test exp") #' tk2reg.type(Rsubkey, "test multi") #' tk2reg.type(Rsubkey, "test dword") #' tk2reg.type(Rsubkey, "test big end") #' #' # Get a value in a key #' tk2reg.get(Rsubkey, "test") #' tk2reg.get(Rsubkey, "test exp") #' tk2reg.get(Rsubkey, "test multi") #' tk2reg.get(Rsubkey, "test dword") #' tk2reg.get(Rsubkey, "test big end") #' #' # Delete a name in a key (take care: dangerous!) #' tk2reg.delete(Rsubkey, "test") #' # Delete a whole key (take care: very dangerous!) #' tk2reg.deletekey(Rsubkey) #' #' # An alternate way to get the path #' tk2reg.get(paste("HKEY_LOCAL_MACHINE", "SYSTEM", "CurrentControlSet", #' "Control", "Session Manager", "Environment", sep = "\\\\"), "path") #' #' # Make sure that currently running apps are warned of your changes in the registry #' tk2reg.broadcast() #' #' # Delete temporary variables #' rm(list = c("Rkey", "Rsubkey")) #' } tk2reg.broadcast <- function() { # Used to warn running apps that something changes in the registry # Use this when you change an environment variable .tk2reg.require() res <- tclvalue(.Tcl("catch {registry broadcast \"Environment\"}")) (res == "0") # "0" if OK, "1" otherwise } #' @export #' @rdname tk2reg tk2reg.delete <- function(keyname, valuename) { # Delete a registry value in a key (take care when using this!) .tk2reg.require() keyname <- as.character(keyname[1]) valuename <- as.character(valuename[1]) res <- tclvalue(.Tcl(paste("catch {registry delete {", keyname, "} {", valuename, "}}", sep = ""))) # return "0" if OK, "1" otherwise (res == "0") } #' @export #' @rdname tk2reg tk2reg.deletekey <- function(keyname) { # Completely delete a registry key (take care when using this!) .tk2reg.require() keyname <- as.character(keyname[1]) res <- tclvalue(.Tcl(paste("catch {registry delete {", keyname, "}}", sep = ""))) # Return "0" if OK (even if already deleted) or "1" (res == "0") } #' @export #' @rdname tk2reg tk2reg.get <- function(keyname, valuename) { # Get the content of a key .tk2reg.require() keyname <- as.character(keyname[1]) valuename <- as.character(valuename[1]) # First get the type of this registry key Type <- tk2reg.type(keyname, valuename) if (is.na(Type)) return(NA) # The key does not exists # The key is found... retrieve its data res <- .Tcl(paste("registry get {", keyname, "} {", valuename, "}", sep = "")) # Convert according to its type... res <- switch(Type, sz = tclvalue(res), # A single string expand_sz = tclvalue(res), # This string is NOT expanded! multi_sz = as.character(res), # A vector of strings dword = as.numeric(res), # Numbers,... check very large numbers! dword_big_endian = as.numeric(res), # Is this correct??? res) # Other types are probably not handled well! res } #' @export #' @rdname tk2reg tk2reg.keys <- function(keyname) { # Get a list of all subkeys in a key .tk2reg.require() keyname <- as.character(keyname[1]) # First check if the command succeeds res <- tclvalue(.Tcl(paste("catch {registry keys {", keyname, "}}", sep = ""))) # Return "0" if OK, "1" otherwise if (res != "0") return(NA) # Indicate that keyname is probably inexistant # Now run the command unprotected as.character(.Tcl(paste("registry keys {", keyname, "}", sep = ""))) } #' @export #' @rdname tk2reg tk2reg.set <- function(keyname, valuename, data, type = c("sz", "expand_sz", "multi_sz", "dword", "dword_big_endian")) { # Set a registry key value .tk2reg.require() keyname <- as.character(keyname[1]) valuename <- as.character(valuename[1]) data <- as.character(data) if (length(data) > 1) # Collapse into one string, using {} as separators data <- paste(data, collapse = "\n") type <- type[1] if (!(type %in% c("sz", "expand_sz", "multi_sz", "dword", "dword_big_endian", "binary", "link", "resource_list", "none"))) stop("Unrecognized 'type'!") res <- tclvalue(.Tcl(paste("catch {registry set {", keyname, "} {", valuename, "} {", data, "} {", type, "}}" , sep = ""))) (res == "0") # Because "0" if OK, and "1" otherwise } #' @export #' @rdname tk2reg tk2reg.setkey <- function(keyname) { # Set a registry key keyname <- as.character(keyname[1]) .tk2reg.require() res <- tclvalue(.Tcl(paste("catch {registry set {", keyname, "}}", sep = ""))) # Return "0" if OK, "1" otherwise (res == "0") } #' @export #' @rdname tk2reg tk2reg.type <- function(keyname, valuename) { # Get the type of a key... .tk2reg.require() keyname <- as.character(keyname[1]) valuename <- as.character(valuename[1]) # First test it to see if the command succeeds (i.e., if the key exists) res <- tclvalue(.Tcl(paste("catch {registry type {", keyname, "} {", valuename, "}}", sep = ""))) # return "0" if OK, "1" otherwise if (res != "0") return(NA) # The key is probably missing # Run the command unprotected now tclvalue(.Tcl(paste("registry type {", keyname, "} {", valuename, "}", sep = ""))) } #' @export #' @rdname tk2reg tk2reg.values <- function(keyname) { # Get a list of all values in a key keyname <- as.character(keyname[1]) .tk2reg.require() # First check if the command succeeds res <- tclvalue(.Tcl(paste("catch {registry values {", keyname, "}}", sep = ""))) # Returns "0" if OK, "1" otherwise if (res != "0") return(NA) # The key probably does not exist! # We issue the command now without protection as.character(.Tcl(paste("registry values {", keyname, "}", sep = ""))) } .tk2reg.require <- function() { # Make sure tcl/tk registry is operational if (.Platform$OS.type != "windows") stop("This is a Windows-specific function!") if (!capabilities("tcltk")) stop("This version of R cannot use Tcl/Tk!") # This should be installed by default with the tcltk package under Windows res <- tclRequire("registry", warn = TRUE) if (inherits(res, "tclObj")) res <- tclvalue(res) if (res[1] == FALSE) stop("Unable to find the 'registry' Tcl/tk package!") res # The package version number } tcltk2/R/tclTask.R0000644000176200001440000002462315017045111013410 0ustar liggesusers#' Schedule and manage delayed tasks #' #' Tcl allows fo scheduling execution of code on the next event loop or after a #' given time (`after` Tcl command). `tclTaskXxx()` functions use it to schedule #' execution of R code with much control from within R (central management of #' scheduled tasks, possibility to define redoable tasks, use of S3 objects to #' keep track of tasks information. The `tclAfterXxx()` functions are low-level #' access to the Tcl `after` command. #' #' @param wait Time in ms to delay the task (take care: approximate value, #' depends on when event loops are triggered). Using a value lower or equal to #' zero, the task is scheduled on the next event loop. #' @param fun Name of the R function to run (you may not supply arguments to #' this function, otherwise it is not scheduled properly; take care of scoping, #' since a copy of the function will be run from within Tcl). #' @param expr An expression to run after 'wait'. #' @param id The R identifier of the task to schedule, if this id contains `#`, #' then, it is replaced by next available number, but you cannot schedule more #' than a thousand tasks with the same name (the system will give up well #' before, anyway). If `NULL` in [tclTaskGet()], retrieve the list of all #' existing tasks. #' @param all If `id = NULL`, `all = TRUE` indicate to list all tasks, including #' hidden ones (with id starting with a dot). #' @param redo Should the task be rescheduled n times, indefinitely #' (`redo = TRUE`) or not (`redo = FALSE`, default, or a value <= 0). #' @param task A Tcl task timer, or its name in Tcl (in the form of #' 'after#xxx'). #' @param x A 'tclTask' object. #' @param ... Further argument to the `print()` method. #' #' @return #' The `tclAfterXxx()` functions return a 'tclObj' with the result of the #' corresponding Tcl function. [tclAfter()] returns the created Tcl timer in #' this object. If 'task' does not exists, [tclAfterInfo()] returns `NULL`. #' #' [tclTaskGet()] returns a 'tclTask' object, a list of such objects, or `NULL` #' if not found. #' #' The four remaining `tclTaskXxx()` functions return invisibly `TRUE` if the #' process is done successfully, `FALSE` otherwise. #' [tclTaskRun()] forces running a task now, even if it is scheduled later. #' #' @export #' @rdname tclTask #' @author Philippe Grosjean #' @seealso [tclFun()], [base::addTaskCallback()], [base::Sys.sleep()] #' @keywords utilities #' #' @examples #' \dontrun{ #' # These cannot be run by examples() but should be OK when pasted #' # into an interactive R session with the tcltk package loaded #' #' # Run just once, after 1 sec #' test <- function () cat("==== Hello from Tcl! ====\n") #' tclTaskSchedule(1000, test()) #' Sys.sleep(2) #' #' # Run ten times a task with a specified id #' test2 <- function () cat("==== Hello again from Tcl! ====\n") #' tclTaskSchedule(1000, test2(), id = "test2", redo = 10) #' Sys.sleep(1) #' #' # Run a function with arguments (will be evaluated in global environment) #' test3 <- function (txt) cat(txt, "\n") #' msg <- "==== First message ====" #' tclTaskSchedule(1000, test3(msg), id = "test3", redo = TRUE) #' Sys.sleep(2) #' msg <- "==== Second message ====" #' Sys.sleep(2) #' #' # Get info on pending tasks #' tclTaskGet() # List all (non hidden) tasks #' tclTaskGet("test2") #' # List all active Tcl timers #' tclAfterInfo() #' #' # Change a task (run 'test3' only once more, after 60 sec) #' tclTaskChange("test3", wait = 60000, redo = 1) #' Sys.sleep(1) #' # ... but don't wait so long and force running 'test3' right now #' tclTaskRun("test3") #' #' Sys.sleep(3) #' # finally, delete all pending tasks #' tclTaskDelete(NULL) #' } tclAfter <- function(wait, fun) { # This is the basic Tcl command, do prefer tclTaskSchedule()! wait <- as.integer(wait)[1] if (wait <= 0) wait <- "idle" # Schedule task on next event loop # Check fun if (!is.function(fun)) stop("'fun' must be a function") # Install a new Tcl timer tcl("after", wait, fun) } #' @export #' @rdname tclTask tclAfterCancel <- function(task) { # Cancel a Tcl timer (no effect if the timer does not exist) tcl("after", "cancel", as.character(task)[1]) } #' @export #' @rdname tclTask tclAfterInfo <- function(task = NULL) { # Get info about a Tcl timer, or list all current ones (using task = NULL) if (is.null(task)) { return(tcl("after", "info")) } else { # First check that task exists task <- as.character(task)[1] ok <- tclvalue(.Tcl(paste("catch {after info ", task, "}", sep = ""))) if (ok == 0) { return(tcl("after", "info", task)) } else return(NULL) } } #' @export #' @rdname tclTask print.tclTask <- function(x, ...) { # Look when the task is run if (x$wait == "idle") { cat("tclTask '", x$id, "' scheduled on next event loop\n", sep = "") } else { cat("tclTask '", x$id, "' scheduled after ", x$wait, " ms ", sep = "") # Determine how much is remaining rem <- x$started + x$wait - proc.time()["elapsed"] * 1000 if (rem <= 0) { cat("(elapsed)\n") } else { cat("(", as.integer(rem), " remaining)\n", sep = "") } } # Look if it is rescheduled if (isTRUE(x$redo)) { cat("Rescheduled forever\n") } else if (x$redo == FALSE || x$redo <= 0) { cat("Not rescheduled\n") } else if (x$redo == 1) { cat("Rescheduled once\n") } else { cat("Rescheduled", x$redo, "times\n") } # Print the command to be executed cat("runs:\n") print(x$expr) invisible(x) } #' @export #' @rdname tclTask tclTaskSchedule <- function(wait, expr, id = "task#", redo = FALSE) { # Schedule a task to be executed after 'wait' ms # If 'wait' is <= 0, schedule for execution on the next event loop # Id is the task name to use (if the task already exists, it is deleted # and replaced by the new definition) wait <- as.integer(wait)[1] if (wait <= 0) wait <- "idle" # Schedule task on next event loop Tasks <- .getTclTasks() TNames <- ls(Tasks, all.names = TRUE) id <- as.character(id)[1] # If 'id' contains '#', replace it by a number (first one available) # but don't allow more than 1000 tasks with same name (to avoid bad # situations with buggy code like infinite loops or so) if (grepl("#", id)) { for (i in 1:1000) { Id <- sub("#", i, id) if (!Id %in% TNames) break } if (Id %in% TNames) stop("Too many tclTasks!") } else { # Delete the task if it already exists if (id %in% TNames) tclTaskDelete(id) Id <- id } if (!isTRUE(redo)) { redo <- as.integer(redo)[1] if (redo <= 0) redo <- FALSE } # Schedule the task, but don't run expr directly, but through tclTaskRun() # Note: if I use tcl("after", wait, tclTaskRun(Id), R is blocked until the # task is done. Here, I must provide the name of a function without args) task <- .makeTclTask(id = Id, wait = wait) # Create a tclTask object containing all info about this task res <- list(task = task, id = Id, expr = substitute(expr), started = proc.time()["elapsed"] * 1000, wait = wait, redo = redo) class(res) <- c("tclTask", class(res)) # Add this task to the list Tasks[[Id]] <- res invisible(res) } #' @export #' @rdname tclTask tclTaskRun <- function(id) { # Execute the code associated with a given task and detemine if the task # should be rescheduled again (repeat argument) id <- as.character(id)[1] Tasks <- .getTclTasks() Task <- Tasks[[id]] if (is.null(Task)) { warning("tclTask '", id, "' is not found") return(invisible(FALSE)) } # Make sure to indicate that we run it once if (!is.logical(Task$redo)) { Task$redo <- Task$redo - 1 if (Task$redo < 1) Task$redo <- FALSE } # Update the original object too Tasks[[id]] <- Task # Run the code associate with this task eval(Task$expr, envir = .GlobalEnv) # Should we delete this task (if repeat is FALSE), or reschedule it? # Note, we read Task again, in case fun() would have changed something there! Task <- Tasks[[id]] # Make sure the tcl timer is destroyed (in case tclTaskRun() is # triggered otherwise) tclTaskDelete(id) if (Task$redo) { # Reschedule the task Task$task <- .makeTclTask(id = id, wait = Task$wait) # and update information in .tclTasks Tasks[[id]] <- Task } invisible(TRUE) } #' @export #' @rdname tclTask tclTaskGet <- function(id = NULL, all = FALSE) { # If id is NULL, list all scheduled tasks, otherwise, give info about a # particular scheduled task if (is.null(id)) { return(ls(.getTclTasks(), all.names = all)) } else { ## Get the data associated with a scheduled task return(.getTclTasks()[[id]]) } } #' @export #' @rdname tclTask tclTaskChange <- function(id, expr, wait, redo) { # Change a characteristic of a scheduled task # Is there something to change? if (missing(expr) && missing(wait) && missing(redo)) return(invisible(FALSE)) # Get task and change it Tasks <- .getTclTasks() Task <- Tasks[[id]] if (is.null(Task)) { warning("tclTask '", id, "' is not found") return(invisible(FALSE)) } if (!missing(expr)) Task$expr <- substitute(expr) if (!missing(wait )) { wait <- as.integer(wait)[1] if (wait <= 0) wait <- "idle" # Schedule task on next event loop Task$wait <- wait } if (!missing(redo)) { if (!isTRUE(redo)) { redo <- as.integer(redo)[1] if (redo <= 0) redo <- FALSE } Task$redo <- redo } # Delete the task and recreate it with the new parameters tclTaskDelete(id) Task$task <- .makeTclTask(id = id, wait = Task$wait) # Update Tasks Tasks[[id]] <- Task invisible(TRUE) } #' @export #' @rdname tclTask tclTaskDelete <- function(id) { Tasks <- .getTclTasks() # Remove a previously scheduled task (if id s NULL, then, remove all tasks) if (is.null(id)) { # Delete all current tasks for (Task in ls(Tasks, all.names = TRUE)) tclAfterCancel(Tasks[[Task]]$task) # Eliminate .tclTasks environment from SciViews:TempEnv rm(list = ".tclTasks", envir = .TempEnv()) } else { # Delete only one task Task <- Tasks[[id]] if (!is.null(Task)) {# The task exists tclAfterCancel(Task$task) rm(list = id, envir = Tasks) } } } .getTclTasks <- function() { # Retrieve references to all scheduled tasks res <- .getTemp(".tclTasks", default = NULL) if (is.null(res)) { res <- new.env(parent = .TempEnv()) .assignTemp(".tclTasks", res) } res } .makeTclTask <- function(id, wait) { run <- function() eval(parse(text = paste('tclTaskRun("', id, '")', sep = ""))) tclAfter(wait, run) } tcltk2/R/tk2edit.R0000755000176200001440000001747614656355210013400 0ustar liggesusers# TODO: Rework all this!!! #dim.tclArray <- function (ta) #{ # nms <- grep(",", names(ta), value = TRUE) # if (length(nms) == 0) return(c(0, 0)) # c(max(as.numeric(gsub(",.*", "", nms))), # max(as.numeric(gsub(".*,", "", nms)))) + 1 #} #' Edit a matrix or data frame in spreadsheet-like editor #' #' A tkTable widget is used to display and edit a matrix or data frame. One #' can edit entries, add or delete rows and columns, ... #' #' @param x A matrix or data frame to edit. #' @param title The title of the editor window. #' @param header Do we display a header? #' @param maxHeight The maximum height of the editor window. #' @param maxWidth The maximum width of the editor window. #' @param fontsize The size of the font to use in the editor window. #' @param ... Further arguments to pass to the function. #' #' @return The function is used for its side-effet, that is, to modify a matrix or data #' frame in a spreadsheet-like editor. #' @note You need the tkTable widget to use this function. #' @export #' @author Jeffrey J. Hallman #' @seealso [tclSetValue()] #' #' @examples #' \dontrun{ #' # These cannot be run by examples() but should be OK when pasted #' # into an interactive R session with the tcltk package loaded #' data(iris) #' tk2edit(iris) #' } tk2edit <- function(x, title = "Matrix Editor", header = NULL, maxHeight = 600, maxWidth = 800, fontsize = 9, ...) { if (!is.tk()) stop("Package Tk is required but not loaded") if (!inherits(tclRequire("Tktable", warn = FALSE), "tclObj")) stop("Tcl package 'Tktable' must be installed first") .Tcl(paste("option add *Table.font {courier", fontsize, "bold}")) old <- options(scipen = 7) on.exit(options(old)) makeCharMat <- function(x) { # Make sure it's a character matrix mat <- matrix(unlist(x), nrow = nrow(as.matrix(x))) dm <- dim(mat) # Check for row and column names hasRownames <- length(rn <- rownames(x)) > 0 hasColnames <- length(cn <- colnames(x)) > 0 # Fake row and column names if they aren't there if (!hasRownames) rn <- paste("[", 1:nrow(x), ",]", sep = "") if (!hasColnames) cn <- paste("[,", 1:ncol(x), "]", sep = "") # Format the columns mat[] <- apply(unclass(mat), 2, format, justify = "right") mat <- rbind(cn, mat) mat <- cbind(c("", rn), mat) mat } fillTclArrayFromCharMat <- function(ta, cm) { # cm[,1] contains column names, while cm[1,] has rownames # cm[1,1] is ignored for (j in 2:ncol(cm)) ta[[0, j - 1]] <- as.tclObj(cm[1, j], drop = TRUE) for (i in 2:nrow(cm)) for (j in 1:ncol(cm)) ta[[i - 1, j - 1]] <- as.tclObj(cm[i, j], drop = TRUE) } tA <- tclArray() cmat <- makeCharMat(x) fillTclArrayFromCharMat(tA, cmat) tt <- tktoplevel() tkwm.title(tt, title) colwidths <- apply(cmat, 2, function(x) max(nchar(x)) + 1 ) nTableCols <- ncol(cmat) if ((moreWidth <- 60 - sum(colwidths)) > 0) { addEach <- moreWidth %/% length(colwidths) if (addEach < 5) { colwidths <- colwidths + addEach + 1 } else { nTableCols <- nTableCols + ceiling(moreWidth / 10) } } tktable <- tkwidget(tt, "table", variable = tA, rows = nrow(cmat), cols = nTableCols, titlerows = 1, titlecols = 1, selecttitle = 1, anchor = "e", multiline = 0, selectmode = "extended", rowseparator = dQuote("\n"), colseparator = dQuote("\t"), background = "white", maxheight = maxHeight, maxwidth = maxWidth, xscrollcommand = function(...) tkset(xscr, ...), yscrollcommand = function(...) tkset(yscr, ...)) xscr <- tkscrollbar(tt, orient = "horizontal", command = function(...) tkxview(tktable, ...)) yscr <- tkscrollbar(tt, command = function(...) tkyview(tktable, ...)) # Set column widths for (i in 1:ncol(cmat)) tcl(tktable, "width", i - 1, colwidths[i]) # Rebind the Backspace key, which somehow gets messed up string <- "bind Table { set ::tk::table::Priv(junk) [%W icursor] if {[string compare {} $::tk::table::Priv(junk)] && $::tk::table::Priv(junk)} { %W delete active [expr {$::tk::table::Priv(junk)-1}] }}" .Tcl(string) # Internal functions for buttons activeRow <- function() as.numeric(tkindex(tktable, "active", "row")) activeCol <- function() as.numeric(tkindex(tktable, "active", "col")) undoEdits <- function() { ta <- tclArray() fillTclArrayFromCharMat(ta, cmat) assign("tA", ta, inherits = TRUE) tkconfigure(tktable, variable = tA) } finish <- function() tkdestroy(tt) cancel <- function() { undoEdits() tkdestroy(tt) } insertRow <- function() { row <- activeRow() col <- activeCol() tkinsert(tktable, "rows", row, 1) newCell <- paste(row + 1, col, sep = ",") tkactivate(tktable, newCell) tksee(tktable, newCell) } insertCol <- function() { row <- activeRow() col <- activeCol() tkinsert(tktable, "cols", col, 1) newCell <- paste(row, col + 1, sep = ",") tkactivate(tktable, newCell) tksee(tktable, newCell) } deleteRow <- function() { if ((row <- activeRow()) != 0) tkdelete(tktable, "rows", row, 1) } deleteCol <- function() { if ((col <- activeCol()) != 0) tkdelete(tktable, "cols", col, 1) } copyRow <- function() { src <- activeRow() if (src != 0) { insertRow() dst <- activeRow() for (j in 0:(ncol(tA) - 1)) tA[[dst, j]] <- tA[[src, j]] } } copyCol <- function() { src <- activeCol() if (src != 0) { insertCol() dst <- activeCol() for (i in 0:(nrow(tA) - 1)) tA[[i, dst]] <- tA[[i,src]] } } finishButton <- tkbutton(tt, text = "Finish", command = finish) cancelButton <- tkbutton(tt, text = "Cancel", command = cancel) undoEditsButton <- tkbutton(tt, text = "Undo Edits", command = undoEdits) insertRowButton <- tkbutton(tt, text = "Insert Row", command = insertRow) copyRowButton <- tkbutton(tt, text = "Copy Row", command = copyRow) deleteRowButton <- tkbutton(tt, text = "Delete Row", command = deleteRow) insertColButton <- tkbutton(tt, text = "Insert Col", command = insertCol) copyColButton <- tkbutton(tt, text = "Copy Col", command = copyCol) deleteColButton <- tkbutton(tt, text = "Delete Col", command = deleteCol) # Layout if (length(header) > 0) { for (label in header) tkgrid(tklabel(tt, text = label), columnspan = 7, sticky = "nw") } tkgrid(tktable, yscr, columnspan = 8) tkgrid.configure(tktable, sticky = "news") tkgrid.configure(yscr, sticky = "nsw") tkgrid(xscr, sticky = "new", columnspan = 8) tkgrid(insertRowButton, copyRowButton, deleteRowButton, sticky = "news") tkgrid(insertColButton, copyColButton, deleteColButton, "x", cancelButton, undoEditsButton, finishButton, sticky = "news") tkgrid.columnconfigure(tt, 3, weight = 1) tkgrid.rowconfigure(tt, length(header), weight = 1) tkactivate(tktable, "0,0") tktag.configure(tktable, "active", background = "lightyellow2") tktag.configure(tktable, "title", state = "normal") tkgrab.set(tt) tkfocus(tt) tkwait.window(tt) outMat <- matrix("", nrow = nrow(tA), ncol = ncol(tA)) for (i in 1:nrow(outMat)) { for (j in 1:ncol(outMat)) { val <- tA[[i - 1,j - 1]] if (is.null(val)) { val <- "" } else { val <- tclvalue(val) } outMat[i,j] <- val } } # Recover row and column names rn <- outMat[, 1][-1] cn <- outMat[1, ][-1] outMat <- outMat[-1, -1, drop = FALSE] # Ignore bad and/or NA row and column names badRownames <- c(grep("\\[.*\\]", rn), (1:length(rn))[is.na(rn)]) if (length(badRownames) != length(rn)) { rn[badRownames] <- "" rownames(outMat) <- rn } badColnames <- c(grep("\\[.*\\]", cn), (1:length(cn))[is.na(cn)]) if (length(badColnames) != length(cn)) { cn[badColnames] <- "" colnames(outMat) <- cn } mode(outMat) <- mode(x) Sys.sleep(0.1) outMat } tcltk2/R/setLanguage.R0000644000176200001440000001341315017046750014247 0ustar liggesusers# Management of locales and message translation using msgcat #' Change or get the language used in R and Tcl/Tk, strings translation in Tcl #' #' The function changes dynamically the language used by both R (messages only) #' and Tcl/Tk, retrieves its current value, and manage string translation in #' Tcl. #' #' @param lang An identification for the targeted language, for instance, \"en\" #' for English, \"en_US\" for american English, \"fr\" for French, \"de\" for #' German, \"it\" for Italian, etc. Facultative argument for [tclmclocale()]. #' @param msg A single character string with the message to translate. #' @param translation The corresponding version in `lang`. Substitutions markers #' like \%s for strings, or \%d for numbers are allowed (same syntax as #' [base::gettextf()]). These translations are added in the Tcl catalog in the #' main domain, i.e., you don't need to give a domain name with [tclmc()] to #' retrieve the translation. #' @param fmt A single character vector of format string. #' @param ... Values to be passed into \code{fmt} for the substitution. #' @param domain The 'domain", i;e., Tcl namespace where the translation is #' defined. Use `NULL` (the default) or `""` for the main domain where #' translations using [tclmcset()] are stored. #' #' @return #' [setLanguage()] returns `TRUE` if language was successfully changed in #' Tcl/Tk, `FALSE` otherwise. [getLanguage()] returns a string with current #' language in use for R, or an empty string if it cannot determinate which is #' the language currently used, and a `tcl.language` attribute with the #' different catalogs that are used in priority order (ending with `""` for no #' translation, i.e., Tcl translations do not return an error, but the initial #' string if the item is not found in the catalog). #' [tclmclocale()] allows to change and get language for Tcl only, without #' changing anything for R. #' #' The two functions [tclmcset()] and [tclmc()] allow to record and retrieve the #' translation of strings in the main R domain. Moreover, [tclmc()] also allows #' to retrieve translations of Tcl strings in other Tcl namespaces (a.k.a., #' domains), see the examples. #' #' @note You need the msgcat Tcl package to use this (but it is provided with #' all recent distributions of Tcl/Tk by default). #' #' @author Philippe Grosjean #' @export #' @keywords utilities #' #' @examples #' # What is the language used by Tcl? #' tclmclocale() #' #' # Define a simple translation in French and German #' tclmcset("de", "Yes", "Ja") #' tclmcset("fr", "Yes", "Oui") #' #' # Determine which language is currently in use in R #' (oldlang <- getLanguage()) #' if (oldlang != "") { #' # Switch to English; test a command that issues a warning and a Tcl string #' setLanguage("en_US") #' 1:3 + 1:2 #' tclmc("Yes") #' #' # Switch to German and test #' setLanguage("de") #' 1:3 + 1:2 #' tclmc("Yes") #' #' # Switch to Belgian French and test #' setLanguage("fr_BE") #' 1:3 + 1:2 #' tclmc("Yes") #' #' # A more complex trnaslation message with a substitution #' tclmcset("fr", "Directory contains %d files", #' "Le repertoire contient %d fichiers") #' tclmc("Directory contains %d files", 9) #' # or from a R/Tcl variable... #' nfiles <- tclVar(12) #' tclmc("Directory contains %d files", tclvalue(nfiles)) #' #' # Retrieve a translation defined in the "tk" domain #' tclmc("Replace existing file?", domain = "tk") #' #' # Tcl dialog boxes are translated according to the current language #' \dontrun{ #' tkgetOpenFile() #' } #' #' # Restore previous language #' setLanguage(oldlang) #' } setLanguage <- function(lang) { # Change locale for both R and Tcl/Tk Sys.setLanguage(substring(lang, 1, 2)) #Sys.setenv(LANGUAGE = lang) Sys.setenv(LANG = lang) #try(Sys.setlocale("LC_MESSAGES", lang), silent = TRUE) # Fails on Windows! res <- tclRequire("msgcat") if (inherits(res, "tclObj")) { .Tcl("namespace import msgcat::*") # If the tcl.language attribute is defined, use it tcllang <- attr(lang, "tcl.language") if (!is.null(tcllang) && tcllang[1] != "") { lang <- tcllang[1] # Use only first item } else { # Tcl does not accept locales like en_US.UF-8: must be en_us only lang <- tolower(sub("^([^.]+)\\..*$", "\\1", lang)) } if (lang == "c") { tclmclocale("en") # Use English by default } else { tclmclocale(lang) } TRUE } else { FALSE } } #' @export #' @rdname setLanguage getLanguage <- function() { # Try to recover current language used for messages and GUI stuff in R lang <- Sys.getenv("LANGUAGE") if (lang == "") lang <- Sys.getlocale("LC_MESSAGES") # This is a bad hack that probably does not work all the time, but at least, # it works under Windows for getting "fr" for French language if (lang == "") lang <- tolower(substr(Sys.getlocale("LC_COLLATE"), 1, 2)) # Try to get language information from Tcl tcllang <- try(as.character(tcl("mcpreferences")), silent = TRUE) attr(lang, "tcl.language") <- tcllang lang } #' @export #' @rdname setLanguage tclmclocale <- function(lang) { if (missing(lang)) { as.character(tcl("mclocale")) } else { # Make sure lang is made compatible to Tcl lang <- tolower(sub("^([^.]+)\\..*$", "\\1", lang)) as.character(tcl("mclocale", lang)) } } #' @export #' @rdname setLanguage tclmcset <- function(lang, msg, translation) invisible(tclvalue(tcl("mcset", lang, msg, translation))) #' @export #' @rdname setLanguage tclmc <- function(fmt, ..., domain = NULL) { if (is.null(domain) || domain == "") { # Simpler form tclvalue(tcl("mc", fmt, ...)) } else { # Need to evaluate in 'domain' Tcl namespace transl <- .Tcl(paste0("namespace eval ", domain, " {set ::Rtransl [mc {", fmt, "}]}")) sprintf(tclvalue(transl), ...) } } tcltk2/R/tk2widgets.R0000755000176200001440000006052315017045264014105 0ustar liggesusers# tk2widgets.R - Support for the ttk widgets # Copyright (c), Philippe Grosjean (phgrosjean@sciviews.org) # Licensed under LGPL 3 or above # # Changes: # - 2012-01-09: reworked tk2label to provide "full options" # # - 2012-01-07: listbox now behaves like a ttk widget, although it is not! # # - 2009-06-30: only use ttk (no tile or plain widgets) # # - 2007-01-01: first version (for tcltk2_1.0-0) # # To do: # - Rework all this and add new widgets like sizegrip, tkplot, ... ### autoscroll #tclRequire("autoscroll") #tt <- tktoplevel() #scrl <- tkscrollbar(tt, orient = "v", command = function(...) tkyview(txt, ...)) #txt <- tktext(tt, highlightthickness = 0, yscrollcommand = function(...) tkset(scrl, ...)) #tkpack(scrl, side = "right", fill = "y") #tkpack(txt, side = "left", fill = "both", expand = 1) #tcl("::autoscroll::autoscroll", scrl) # Management of locales and message translation using msgcat #' A series of versatile using either themable ttk widgets #' #' A series of widgets you can use in your Tk windows/dialog boxes. #' #' @param parent The parent window. #' @param tip A tooltip to display for this widget (optional). #' @param label A single character string used to label that widget (optional). #' @param tag Ay object that you would like to associate with this widget #' (optional). #' @param cfglist A named list with configuration parameters and values to #' apply. #' @param wrap Do we wrap long lines in the widget? #' @param values A character vector with values to use to populate the widget. #' @param value A character vector with current value for the widget, or #' currently selected values, if multiple selection is allowed. Takes precedence #' on `selection`. #' @param selection A numeric (indices) vector with current selection. #' @param selectmode The selection mode for this widget. `extended` is the #' usual choice for multiselection `tk2listbox()`. #' @param height The height of the widget. #' @param scroll Do we add scrollbars? Possible values are `"x"`, `"y"`, #' `"both"` or `"none"`; can be abridged. #' @param autoscroll Do we automatically hide scrollbars if not needed? Possible #' values are the same as for the `scroll` argument. #' @param enabled Is the widget enabled or disabled? #' @param text The text to display in the widget. #' @param justify How text is justified? #' @param tabs The tabs to create in the notebook widget. #' @param width The desired width. Use a negative value to use `aspect` instead. #' @param aspect Sets the aspect ratio of the widget (100 = square, 200 = twice #' as large, 50 = twice as tall). Only used if `width` is negative. #' @param orientation Either `"horizontal"` or `"vertical"`. #' @param activebackground Color to use for active background of menu items (if #' not provided, a reasonable default value is used). #' @param activeforeground Color to use for active foreground of menu items (if #' not provided, a reasonable default value is used). #' @param ... Further arguments passed to the widget. #' #' @return #' The reference to the created widget. #' #' @note You need Tk 8.5 or above to use these widgets. #' #' @author Philippe Grosjean #' @export #' @rdname tk2widgets #' @seealso [is.ttk()] #' @keywords utilities #' #' @examples #' \dontrun{ #' # These cannot be run by examples() but should be OK when pasted #' # into an interactive R session with the tcltk package loaded #' #' # A tk2notebook example #' tt2 <- tktoplevel() #' nb <- tk2notebook(tt2, tabs = c("Test", "Button")) #' tkpack(nb, fill = "both", expand = 1) #' tb1 <- tk2notetab(nb, "Test") #' lab <- tk2label(tb1, text = "Nothing here.") #' tkpack(lab) #' tb2 <- tk2notetab(nb, "Button") #' but <- tk2button(tb2, text = "Click me", command = function() tkdestroy(tt2)) #' tkgrid(but) #' tk2notetab.select(nb, "Button") #' tk2notetab.text(nb) # Text of the currently selected tab #' #' # A simple tk2panedwindow example #' tt2 <- tktoplevel() #' pw <- tk2panedwindow(tt2, orient = "vertical") #' lpw.1 <- tk2text(pw) #' lpw.2 <- tk2text(pw) #' tkadd(pw, lpw.1)#, minsize = 100) #' tkadd(pw, lpw.2)#, minsize = 70) #' but <- tk2button(tt2, text = "OK", width = 10, #' command = function() tkdestroy(tt2)) #' tkpack(pw, fill = "both", expand = "yes") #' tkpack(but) #' # Resize the window and move the panel separator with the mouse #' #' # A tk2combobox example #' tt2 <- tktoplevel() #' cb <- tk2combobox(tt2) #' tkgrid(cb) #' # Fill the combobox list #' fruits <- c("Apple", "Orange", "Banana") #' tk2list.set(cb, fruits) #' tk2list.insert(cb, "end", "Scoubidou", "Pear") #' tk2list.delete(cb, 3) # 0-based index! #' tk2list.size(cb) #' tk2list.get(cb) # All items #' # Link current selection to a variable #' Fruit <- tclVar("Pear") #' tkconfigure(cb, textvariable = Fruit) #' # Create a button to get the content of the combobox #' but <- tk2button(tt2, text = "OK", width = 10, #' command = function() {tkdestroy(tt2); cat(tclvalue(Fruit), "\n")}) #' tkgrid(but) #' #' # An example of a tk2spinbox widget #' tt2 <- tktoplevel() #' tspin <- tk2spinbox(tt2, from = 2, to = 20, increment = 2) #' tkgrid(tspin) #' # This widget is not added yet into tcltk2! #' #tdial <- tk2dial(tt2, from = 0, to = 20, resolution = 0.5, width = 70, #' # tickinterval = 2) #' #tkgrid(tdial) #' tbut <- tk2button(tt2, text = "OK", width = 10, #' command = function() tkdestroy(tt2)) #' tkgrid(tbut) #' #' # A tk2mclistbox example #' tt2 <- tktoplevel() #' mlb <- tk2mclistbox(tt2, width = 55, resizablecolumns = TRUE) #' # Define the columns #' tk2column(mlb, "add", "name", label = "First name", width = 20) #' tk2column(mlb, "add", "lastname", label = "Last name", width = 20) #' tk2column(mlb, "add", "org", label = "Organisation", width = 15) #' tkgrid(mlb) #' # Fill the multicolumn list (we can use a vector, or a matrix of character strings) #' item1 <- c("Bryan", "Oackley", "ChannelPoint") #' items <- matrix(c("John", "Ousterhout", "Scriptics", "Steve", "Miller", "TclTk inc."), #' ncol = 3, byrow = TRUE) #' tk2insert.multi(mlb, "end", item1) #' tk2insert.multi(mlb, "end", items) #' # TODO: bind events #' # Ex: .listbox label bind date "sortByDate %W" #' # See the example.tcl in .\libs\mclistbox1.02 for a more complex example #' # Create a button to close the dialog box #' but <- tk2button(tt2, text = "OK", width = 10, #' command = function() tkdestroy(tt2)) #' tkgrid(but) #' #' # A simple tk2table example (Tktable is required here!) #' myRarray <- c("Animal", "\"sphinx moth\"", "oyster", "Type", "insect", "mollusk") #' dim(myRarray) <- c(3, 2) #' for (i in (0:2)) #' for (j in (0:1)) #' .Tcl(paste("set tclarray(", i, ",", j, ") ", myRarray[i+1, j+1], sep = "")) #' tt2 <- tktoplevel() #' table1 <- tk2table(tt2, variable = "tclarray", rows = "3", cols = "2", #' titlerows = "1", selectmode = "extended", colwidth = "25", background = "white") #' tkpack(table1) #' # A tablelist example #' tt <- tktoplevel() #' tlist <- tk2tablelist(tt, columntitles = c("First column", "Second column"), #' stretch = "all", expand = 1) #' tkpack(tlist, fill = "both") #' tkinsert(tlist, "end", c("first row", "another value")) #' tkinsert(tlist, "end", c("another row", "bla bla")) #' tbut <- tk2button(tt, text = "Done", command = function () tkdestroy(tt)) #' tkpack(tbut) #' } tk2button <- function(parent, tip = "", ...) { if (!is.ttk()) stop("Tcl/Tk >= 8.5 is required") w <- tkwidget(parent, "ttk::button", ...) if (tip != "") tk2tip(w, tip) class(w) <- c("tk2button", "tk2widget", class(w)) w } #' @export #' @rdname tk2widgets tk2canvas <- function(parent, tip = "", ...) { if (!is.ttk()) stop("Tcl/Tk >= 8.5 is required") ### TODO: use autoscroll here! # Default background to fieldbackground if (any(names(list(...)) == "background")) { w <- tkwidget(parent, "canvas", ...) } else { background <- tclvalue(.Tcl("ttk::style lookup TEntry -fieldbackground")) if (background == "") background <- "white" w <- tkwidget(parent, "canvas", background = background, ...) } if (tip != "") tk2tip(w, tip) class(w) <- c("tk2canvas", "tk2widget", class(w)) w } #' @export #' @rdname tk2widgets tk2checkbutton <- function(parent, tip = "", ...) { ### TODO: associate with a variable and set both states values if (!is.ttk()) stop("Tcl/Tk >= 8.5 is required") w <- tkwidget(parent, "ttk::checkbutton", ...) if (tip != "") tk2tip(w, tip) class(w) <- c("tk2checkbutton", "tk2widget", class(w)) w } #' @export #' @rdname tk2widgets tk2combobox <- function(parent, tip = "", ...) { ### TODO: associate the list and results with a variable and intialize the widget if (!is.ttk()) stop("Tcl/Tk >= 8.5 is required") w <- tkwidget(parent, "ttk::combobox", ...) if (tip != "") tk2tip(w, tip) class(w) <- c("tk2combobox", "tk2widget", class(w)) w } ### TODO: a centry widget #' @export #' @rdname tk2widgets tk2entry <- function(parent, tip = "", ...) { ### TODO: add cut/copy/paste/select all/clear context menu if (!is.ttk()) stop("Tcl/Tk >= 8.5 is required") w <- tkwidget(parent, "ttk::entry", cursor = "xterm", ...) if (tip != "") tk2tip(w, tip) class(w) <- c("tk2entry", "tk2widget", class(w)) w } #' @export #' @rdname tk2widgets tk2frame <- function(parent, ...) { if (!is.ttk()) stop("Tcl/Tk >= 8.5 is required") w <- tkwidget(parent, "ttk::frame", ...) class(w) <- c("tk2frame", "tk2widget", class(w)) w } #' @export #' @rdname tk2widgets tk2label <- function(parent, tip, label, tag, cfglist, wrap = FALSE, ...) { # Also image, text, textvariable, label & tag for data # width = -10, compound = "left", justify = "left", wrap = FALSE for config # Special treatment from wrap (wraplength) if (!is.ttk()) stop("Tcl/Tk >= 8.5 is required") # If a config list is provided, rework arguments if (!missing(cfglist)) { args <- .mergeList(cfglist, list(...)) args$parent <- parent if (!missing(tip)) args$tip <- tip if (!missing(label)) args$label <- label if (!missing(tag)) args$tag <- tag return(do.call(tk2label, args)) } # Create the widget and the corresponding R object w <- tkwidget(parent, "ttk::label", ...) class(w) <- c("tk2label", "tk2widget", class(w)) if (!missing(tip)) tip(w) <- tip if (!missing(label)) label(w) <- label if (!missing(tag)) tag(w) <- tag # Special treatment for 'wrap' argument that does not exists in ttk::label if (!missing(wrap)) { # We need width width <- abs(as.integer(tclvalue(tkcget(w, "-width")))) if (isTRUE(wrap)) wraplength <- .wraplength(w, width) else wraplength <- 0 tkconfigure(w, wraplength = wraplength) # If width is not reapplied after wraplength, the text is not always # wrapped in the widget (is this a bug?) if (wraplength > 0 && length(width)) tkconfigure(w, width = width) } w } #' @export #' @rdname tk2widgets tk2labelframe <- function(parent, ...) { if (!is.ttk()) stop("Tcl/Tk >= 8.5 is required") w <- tkwidget(parent, "ttk::labelframe", ...) class(w) <- c("tk2labelframe", "tk2widget", class(w)) w } ## TODO: I need to rework this on the same scheme as tk2label #' @export #' @rdname tk2widgets tk2listbox <- function(parent, values, value, selection, selectmode = c("extended", "single", "browse", "multiple"), height = 5, tip = "", scroll = "both", autoscroll = "x", enabled = TRUE, ...) { # Check conditions and arguments if (!is.ttk()) stop("Tcl/Tk >= 8.5 is required") selectmode <- match.arg(selectmode) scrolls <- c("x", "y", "both", "none") scroll <- match.arg(scroll, scrolls) autoscroll <- match.arg(autoscroll, scrolls) if (missing(values) || length(values) == 0) { values <- NULL } else { values <- as.character(values) } # We provide either value or selection... translate value into selection if (missing(selection)) selection <- NULL if (!missing(value)) { if (is.null(values) || length(values) < 1) { selection <- NULL } else { selection <- (1:length(values))[values %in% as.character(value)] } } if (length(selection) == 0 || is.null(values) || length(values) < 1) { selection <- NULL } else { selection <- sort(as.integer(round(selection))) if (selection[1] < 1) stop("Numerical selections must be indices > 0") if (selection[1] > length(values)) selection <- NULL if (selectmode == "single" && length(selection) > 1) { warning("Only lowest selection used in single selection mode") selection <- selection[1] } } # Location of the widget depends if we add scrollbars or not background <- tclvalue(.Tcl("ttk::style lookup TEntry -fieldbackground")) if (background == "") background <- "white" if (scroll == "none") { w <- tkwidget(parent, "listbox", font = "TkDefaultFont", borderwidth = 1, relief = "sunken", activestyle = "dotbox", selectmode = selectmode, height = height, exportselection = 0, background = background, ...) } else {# We need to create a tk2frame as parent of the listbox wf <- tk2frame(parent) w <- tkwidget(wf, "listbox", font = "TkDefaultFont", borderwidth = 1, relief = "sunken", activestyle = "dotbox", selectmode = selectmode, height = height, exportselection = 0, background = background, ...) } # Make it react to tk2theme changes, and integrate the listbox as much # as possible with current ttk theme #restyleListbox <- function (W) { # # Restyle the listbox according to current ttk style # # Note: font is set to TkDefaultFont => already managed there! # tkconfigure(W, # foreground = tk2style("tk2entry", "foreground", # default = "#000000"), # borderwidth = tk2style("", "borderwidth", default = 0), # disabledforeground = tk2style("tk2entry", "foreground", # "disabled", default = "#a3a3a3"), # highlightbackground = tk2style("tk2entry", "selectbackground", # default = "#c3c3c3"), # highlightcolor = tk2style("tk2entry", "selectbackground", # default = "#c3c3c3"), # selectbackground = tk2style("tk2entry", "selectbackground", # default = "#c3c3c3"), # selectforeground = tk2style("tk2entry", "selectforeground", # default = "#ffffff") # ) #} # Restyle it now #restyleListbox(w) restyleListbox <- function(W) { background <- tclvalue(.Tcl("ttk::style lookup TEntry -fieldbackground")) if (background == "") background <- "white" tkconfigure(W, background = background) } # If there are values and/or selections, populate the list now for (item in values) tkinsert(w, "end", item) if (!is.null(selection)) { for (sel in selection) tkselection.set(w, sel - 1) # Because Tcl uses 0-based indexing! tksee(w, selection[1]) # Ensure that the first selected item is visible } # Possibly add a tooltip if (tip != "") tk2tip(w, tip) ## Do we add scrollbars? if (scroll == "none") { ## Apply bindings to original listbox tkbind(w, "<>", restyleListbox) tkbind(w, "<1>", function(W) tkfocus(W)) # Needed for mouseweel action # Do we disable it? if (!isTRUE(enabled)) tkconfigure(w, state = "disabled") # Done... just return the widget class(w) <- c("tk2listbox", "tk2widget", class(w)) return(w) } else { # Add (autohide) scrollbar(s) tcl("scrolledWidget", w, wf, scroll, autoscroll) # Apply bindings to frame container tkbind(wf, "<>", restyleListbox) tkbind(wf, "<1>", function(W) tkfocus(W)) # Needed for mouseweel action class(wf) <- c("tk2listbox", "tk2widget", class(w)) # Do we disable it? if (!isTRUE(enabled)) tkconfigure(wf, state = "disabled") return(wf) } } #' @export #' @rdname tk2widgets tk2mclistbox <- function(parent, tip ="", ...) { ### TODO: a tile equivalent of this widget ### TODO: or adjust the header: font, color and frame if (!is.ttk()) stop("Tcl/Tk >= 8.5 is required") res <- tclRequire("mclistbox") if (!inherits(res, "tclObj")) stop("Impossible to load the Tcl mclistbox package; check your Tcl/Tk installation") background <- tclvalue(.Tcl("ttk::style lookup TEntry -fieldbackground")) if (background == "") background <- "white" w <- tkwidget(parent, "mclistbox::mclistbox", font = "TkDefaultFont", background = background, ...) tkconfigure(w, relief = "flat") if (tip != "") tk2tip(w, tip) class(w) <- c("tk2mclistbox", "tk2widget", class(w)) w } #' @export #' @rdname tk2widgets tk2menu <- function(parent, activebackground, activeforeground, ...) { if (!is.ttk()) stop("Tcl/Tk >= 8.5 is required") w <- tkwidget(parent, "menu", ...) if (missing(activebackground)) activebackground <- tk2style("tk2button", "selectbackground") if (activebackground == "") activebackground = "darkblue" # Default value if (missing(activeforeground)) activeforeground <- tk2style("tk2button", "selectforeground") if (activeforeground == "") activeforeground = "white" # Default value tkconfigure(w, activebackground = activebackground, activeforeground = activeforeground) class(w) <- c("tk2menu", "tk2widget", class(w)) w } #' @export #' @rdname tk2widgets tk2menubutton <- function(parent, tip = "", ...) { if (!is.ttk()) stop("Tcl/Tk >= 8.5 is required") w <- tkwidget(parent, "ttk::menubutton", ...) if (tip != "") tk2tip(w, tip) class(w) <- c("tk2menubutton", "tk2widget", class(w)) w } #' @export #' @rdname tk2widgets tk2message <- function(parent, text = "", justify = c("left", "center", "right"), width = -1, aspect = 150, tip = "", ...) { if (!is.ttk()) stop("Tcl/Tk >= 8.5 is required") justify <- as.character(justify[1]) w <- tkwidget(parent, "message", text = text, justify = justify, width = width, aspect = aspect, font = "TkDefaultFont", ...) if (tip != "") tk2tip(w, tip) class(w) <- c("tk2message", "tk2widget", class(w)) w } #' @export #' @rdname tk2widgets tk2notebook <- function(parent, tabs, ...) { if (!is.ttk()) stop("Tcl/Tk >= 8.5 is required") w <- tkwidget(parent, "ttk::notebook", ...) # Add pages tabs <- as.character(tabs) for (tab in tabs) { tframe <- tk2frame(w) tkadd(w, tframe, text = tab, sticky = "nsew") } tk2notetraverse(w) # Enable keyboard traversal for this notebook class(w) <- c("tk2notebook", "tk2widget", class(w)) w } #' @export #' @rdname tk2widgets tk2panedwindow <- function(parent, orientation = c("horizontal", "vertical"), ...) { if (!is.ttk()) stop("Tcl/Tk >= 8.5 is required") orientation <- as.character(orientation[1]) w <- tkwidget(parent, "ttk::panedwindow", orient = orientation, ...) class(w) <- c("tk2panedwindow", "tk2widget", class(w)) w } #' @export #' @rdname tk2widgets tk2progress <- function(parent, orientation = c("horizontal", "vertical"), tip = "", ...) { if (!is.ttk()) stop("Tcl/Tk >= 8.5 is required") orientation <- as.character(orientation[1]) w <- tkwidget(parent, "ttk::progressbar", ...) if (tip != "") tk2tip(w, tip) class(w) <- c("tk2progress", "tk2widget", class(w)) w } #' @export #' @rdname tk2widgets tk2radiobutton <- function(parent, tip = "", ...) { ### TODO: associate with a variable and set both states values if (!is.ttk()) stop("Tcl/Tk >= 8.5 is required") w <- tkwidget(parent, "ttk::radiobutton", ...) if (tip != "") tk2tip(w, tip) class(w) <- c("tk2radiobutton", "tk2widget", class(w)) w } #' @export #' @rdname tk2widgets tk2scale <- function(parent, orientation = c("horizontal", "vertical"), tip = "", ...) { if (!is.ttk()) stop("Tcl/Tk >= 8.5 is required") orientation <- as.character(orientation[1]) w <- tkwidget(parent, "ttk::scale", orient = orientation, ...) if (tip != "") tk2tip(w, tip) class(w) <- c("tk2scale", "tk2widget", class(w)) w } #' @export #' @rdname tk2widgets tk2scrollbar <- function(parent, orientation = c("horizontal", "vertical"), ...) { if (!is.ttk()) stop("Tcl/Tk >= 8.5 is required") orientation <- as.character(orientation[1]) w <- tkwidget(parent, "ttk::scrollbar", orient = orientation, ...) class(w) <- c("tk2scrollbar", "tk2widget", class(w)) w } #' @export #' @rdname tk2widgets tk2separator <- function(parent, orientation = c("horizontal", "vertical"), ...) { if (!is.ttk()) stop("Tcl/Tk >= 8.5 is required") orientation <- as.character(orientation[1]) w <- tkwidget(parent, "ttk::separator", orient = orientation, ...) class(w) <- c("tk2separator", "tk2widget", class(w)) w } #' @export #' @rdname tk2widgets tk2spinbox <- function(parent, tip = "", ...) { if (!is.ttk()) stop("Tcl/Tk >= 8.5 is required") # Default background to fieldbackground if (any(names(list(...)) == "background")) { w <- tkwidget(parent, "spinbox", font = "TkDefaultFont", relief = "solid", borderwidth = 1, ...) } else { background <- tclvalue(.Tcl("ttk::style lookup TEntry -fieldbackground")) if (background == "") background <- "white" w <- tkwidget(parent, "spinbox", font = "TkDefaultFont", relief = "solid", borderwidth = 1, background = background, ...) } if (tip != "") tk2tip(w, tip) class(w) <- c("tk2spinbox", "tk2widget", class(w)) w } #' @export #' @rdname tk2widgets tk2text <- function(parent, tip = "", ...) { ### TODO: autohide scrollbars if (!is.ttk()) stop("Tcl/Tk >= 8.5 is required") # Default background to fieldbackground if (any(names(list(...)) == "background")) { w <- tkwidget(parent, "text", font = "TkTextFont", ...) } else { background <- tclvalue(.Tcl("ttk::style lookup TEntry -fieldbackground")) if (background == "") background <- "white" w <- tkwidget(parent, "text", font = "TkTextFont", background = background, ...) } tkconfigure(w, relief = "flat") if (tip != "") tk2tip(w, tip) class(w) <- c("tk2text", "tk2widget", class(w)) w } #' @export #' @rdname tk2widgets tk2ctext <- function(parent, tip = "", ...) { ### TODO: autohide scrollbars if (!is.ttk()) stop("Tcl/Tk >= 8.5 is required") tclRequire("ctext") # Default background to fieldbackground if (any(names(list(...)) == "background")) { w <- tkwidget(parent, "ctext", font = "TkFixedFont", ...) } else { background <- tclvalue(.Tcl("ttk::style lookup TEntry -fieldbackground")) if (background == "") background <- "white" w <- tkwidget(parent, "ctext", font = "TkFixedFont", background = background, ...) } tkconfigure(w, relief = "flat") if (tip != "") tk2tip(w, tip) class(w) <- c("tk2ctext", "tk2widget", class(w)) w } ### TODO: rework this, using ttk::treeview #' @export #' @rdname tk2widgets tk2tree <- function(parent, tip = "", ...) { ### TODO: better icons! # Reasonable default icons for files and folders if (!is.ttk()) stop("Tcl/Tk >= 8.5 is required") images <- as.character(tcl("image", "names")) if (!"Tree:dir" %in% images) .Tcl("image create photo Tree:dir -data {R0lGODdhEAAQAPIAAAAAAHh4eLi4uPj4APj4+P///wAAAAAAACwAAAAAEAAQAAADPVi63P4wLkKCtTTnUsXwQqBtAfh910UU4ugGAEucpgnLNY3Gop7folwNOBOeiEYQ0acDpp6pGAFArVqthQQAO///}") if (!"Tree:file" %in% images) .Tcl("image create photo Tree:file -data {R0lGODdhEAAQAPIAAAAAAHh4eLi4uPj4+P///wAAAAAAAAAAACwAAAAAEAAQAAADPkixzPODyADrWE8qC8WN0+BZAmBq1GMOqwigXFXCrGk/cxjjr27fLtout6n9eMIYMTXsFZsogXRKJf6uP0kCADv/}") ### TODO: correct support of font w <- tkwidget(parent, "Tree:create") #, font = "TkDefaultFont", ...) tkconfigure(w, relief = "flat") if (tip != "") tk2tip(w, tip) class(w) <- c("tk2tree", "tk2widget", class(w)) w } #' @export #' @rdname tk2widgets tk2table <- function(parent, ...) { if (!is.ttk()) stop("Tcl/Tk >= 8.5 is required") if (inherits(tclRequire("Tktable", warn = FALSE), "tclObj")) { w <- tkwidget(parent, "table", font = "TkDefaultFont", ...) class(w) <- c("tk2table", "tk2widget", class(w)) return(w) } else { stop("Tcl package 'Tktable' must be installed first") } } #' @export #' @rdname tk2widgets tk2tablelist <- function(parent, ...) { if (!is.ttk()) stop("Tcl/Tk >= 8.5 is required") if (inherits(tclRequire("tablelist_tile", warn = FALSE), "tclObj")) { # Default background to fieldbackground if (any(names(list(...)) == "background")) { w <- tkwidget(parent, "tablelist::tablelist", font = "TkDefaultFont", ...) } else { background <- tclvalue(.Tcl("ttk::style lookup TEntry -fieldbackground")) if (background == "") background <- "white" w <- tkwidget(parent, "tablelist::tablelist", font = "TkDefaultFont", background = background, ...) } class(w) <- c("tk2tablelist", "tk2widget", class(w)) return(w) } else { stop("Tcl package 'tablelist' must be installed first") } } tcltk2/R/tk2tip.R0000755000176200001440000000550715017045255013234 0ustar liggesusers#' Display and manage tooltips in Tk widgets #' #' [tk2tip()] provides a simple mechanism to display tooltips on Tk widgets when #' the mouse cursor hoovers on top of them. #' #' @param widget The widget to which a tooltip is attached. #' @param message The message of the tooltip (\code{""} to remove the tooltip). #' @param x A tk2widget object. #' @param ... Further arguments to the method (unused, but reserved for #' future use). #' @param value The message of the tooltip, or \code{""} to remove the tip. #' #' @return #' The current tip or `NULL` depending on the function. #' #' @note #' This implementation is done in pure Tcl code. #' #' @export #' @author Philippe Grosjean #' @seealso [tk2button()], [label()] #' @keywords utilities #' #' @examples #' \dontrun{ #' # These cannot be run by examples() but should be OK when pasted #' # into an interactive R session with the tcltk package loaded #' #' # Using plain Tcl/Tk label and button (tk2XXX equivalent have built-in #' # tooltip features) #' tt <- tktoplevel() #' lb <- tklabel(tt, text = "Move mouse over me, or over the button to see tooltip") #' tkgrid(lb) #' tk2tip(lb, "A tooltip for the label \ndisplayed on two lines") #' but <- tkbutton(tt, text = "Exit", width = 10, #' command = function() tkdestroy(tt)) #' tkgrid(but) #' tk2tip(but, "Exit from this dialog box") #' #' # To test tk2killtip(), move mouse on top of a widget #' # so that the tip is visible, and force killing it manually using: #' tk2killtip() #' # Move again to the widget: the tip is displayed again. #' #' # With tk2widgets, the tip() method can also be used: #' lb2 <- tk2label(tt, text = "Move also over me to see the tooltip") #' tkgrid(lb2) #' tip(lb2) # No tip yet #' tip(lb2) <- "Now the tooltip is there!" #' # Move the mouse over that last label #' #' tip(lb2) # Yes, this is my tooltip #' tip(lb2) <- NULL # To eliminate the tooltip for this widget #' } tk2tip <- function(widget, message) { if (!is.tk()) stop("Package Tk is required but not loaded") if (is.null(message)) message <- "" res <- tclRequire("tooltip") if (inherits(res, "tclObj")) { res <- tcl("tooltip::tooltip", widget, message) # Store tip text in the object (use NULL instead of "" for no tip) if (message == "") message <- NULL widget$env$tip <- message } else { stop("cannot find tcl package 'tooltip'") } invisible(res) } #' @export #' @rdname tk2tip tk2killtip <- function() { if (!is.tk()) stop("Package Tk is required but not loaded") invisible(tcl("tooltip::hide")) } #' @export #' @rdname tk2tip tip <- function(x, ...) UseMethod("tip") #' @export #' @rdname tk2tip tip.tk2widget <- function(x, ...) x$env$tip #' @export #' @rdname tk2tip `tip<-` <- function(x, value) UseMethod("tip<-") #' @export #' @rdname tk2tip `tip<-.tk2widget` <- function(x, value) { tk2tip(x, value) x } tcltk2/R/tcltk2-package.R0000644000176200001440000000200215017041713014566 0ustar liggesusers#' @details #' The \{tcltk2\} package provides additions to the \{tcltk\} base package. #' #' Many Tk widgets are added. Also, features of the Tcl language that can be #' useful also in R are made accessible through R functions. #' #' @keywords internal "_PACKAGE" #' @importFrom tcltk tcl .Tcl tclRequire tclObj as.tclObj tclVar tclArray tclvalue tclvalue<- tclServiceMode .Tcl.callback tktoplevel tkwidget tkfont.names tkfont.configure tkfont.families tkfont.measure tkfont.actual tkconfigure tkcget tkcurselection tkselection.clear tkselection.set tksee tkset tksize tkwm.title tkxview tkyview tkindex tkdestroy tkinsert tkactivate tkbutton tkgrid tklabel tkgrid.configure tkgrid.columnconfigure tkgrid.rowconfigure tktag.configure tkgrab.set tkfocus tkwait.window tkwm.iconbitmap tkbind tkadd tkmessageBox tkscrollbar tkdelete tkselect tkbindtags tkget # The following block is used by usethis to automatically manage # roxygen namespace tags. Modify with care! ## usethis namespace: start ## usethis namespace: end NULL tcltk2/R/tk2commands.R0000755000176200001440000005470615017045141014240 0ustar liggesusers# TODO: # - Rework all this... # - Style option of Tile widgets? # - Implement style element options ... #' Tk commands associated with the tk2XXX widgets #' #' These commands supplement those available in the tcltk package to ease #' manipulation of tk2XXX widgets. #' #' @param widget The widget to which these actions apply. #' @param action Which kind of action? #' @param ... Further arguments to the action. #' @param where Where are these item added in the list (by default, at the end). #' @param items The items to add (either a vector for a single line, or a matrix #' for more items). #' @param first The 0-based first index to consider in the list. #' @param last The 0-based last index to consider in the list, or `"end"` for #' using the last element of the list. #' @param index The 0-based index where to insert items in the list. #' @param nb A tk2notebook widget ('tclObj' object). #' @param tab The name (text) of a tab in a notebook. #' @param state The new state of the widget, or the state to inquiry. #' @param theme A theme to use (character string). #' @param class The class of the tk2widget (either the Tk class, like `TButton`, #' or the name of the function that creates it, like [tk2button()]. #' @param style A character string with the name of the style to retrieve. #' @param default The default value to return in case this style is not found. #' @param x Either a tk2widget object, or a character string with its class #' name. #' #' @details #' [tk2column()] manipulate columns of a tk2mclistbox widget, #' [tk2insert.multi()] is used to insert multiple field entries in a #' tk2mclistbox widget, #' [is.tk()] determines if the tk package is loaded (on some platforms it is #' possible to load the tcltk package without tk, for instance, in batch mode). #' [is.ttk()] determines if 'ttk' widgets (styled widgets) used by the #' `tk2XXX()` functions are available (you need Tk >= 8.5). #' #' @return #' Nothing, these functions are used for their side-effect of changing the state #' of Tk widgets #' #' @note #' In comparison with traditional Tk widgets, ttk proposes an advances mechanism #' for styling the widgets with "themes". By default, it adapts to the current #' platform (for instance, under Windows, all widgets take the appearance of #' Windows themed widgets (even with custom themes applied!). Usual Tk widgets #' are ALWAYS displayed in old-looking fashion under Windows. If you want, you #' can switch dynamically to a different theme among those available (list them #' using [tk2theme.list()], and switch to another one with `tk2theme(newtheme)`. #' This is most useful to see how your GUI elements and dialog boxes look like #' on foreign systems. If you prefer, let's say, a Unix look of the R GUI #' elements under Windows, these functions are also useful. If you are more #' adventurous, you can even design your own themes (see the tile documentation #' on the Tcl wiki). #' #' @export #' @rdname tk2commands #' @author Philippe Grosjean #' @seealso [tk2button()], [tk2tip()] #' @keywords utilities #' #' @examples #' \dontrun{ #' # These cannot be run by examples() but should be OK when pasted #' # into an interactive R session with the tcltk package loaded #' #' tt <- tktoplevel() #' # A label with a image and some text #' file <- system.file("gui", "SciViews.gif", package = "tcltk2") #' #' # Make this a tk2image function... #' Image <- tclVar() #' tkimage.create("photo", Image, file = file) #' #' tlabel <- tk2label(tt, image = Image, #' text = "A label with an image") #' tkpack(tlabel) #' config(tlabel, compound = "left") #' #' tlabel2 <- tk2label(tt, text = "A disabled label") #' tkpack(tlabel2) #' disabled(tlabel2) <- TRUE #' #' fruits <- c("Apple", "Orange", "Banana") #' tcombo <- tk2combobox(tt, values = fruits) #' tkpack(tcombo) #' tkinsert(tcombo, 0, "Apple") #' #' # Buttons #' tbut <- tk2button(tt, text = "Enabled") #' tbut2 <- tk2button(tt, text = "Disabled") #' tkpack(tbut, tbut2) #' tkconfigure(tbut2, state = "disabled") #' #' tcheck <- tk2checkbutton(tt, text = "Some checkbox") #' tcheck2 <- tk2checkbutton(tt, text = "Disabled checkbox") #' tkconfigure(tcheck2, state = "disabled") #' tcheck3 <- tk2checkbutton(tt, text = "Disabled and selected") #' tkpack(tcheck, tcheck2, tcheck3) #' cbValue <- tclVar("1") #' tkconfigure(tcheck3, variable = cbValue) #' tkconfigure(tcheck3, state = "disabled") #' #' tradio <- tk2radiobutton(tt, text = "Some radiobutton") #' tradio2 <- tk2radiobutton(tt, text = "Disabled and checked") #' tkpack(tradio, tradio2) #' tkconfigure(tradio2, state = "checked") #' tkconfigure(tradio2, state = "disabled") #' #' # Menu allowing to change ttk theme #' topMenu <- tkmenu(tt) # Create a menu #' tkconfigure(tt, menu = topMenu) # Add it to the 'tt' window #' themes <- tk2theme.list() #' themeMenu <- tkmenu(topMenu, tearoff = FALSE) #' if ("alt" %in% themes) tkadd(themeMenu, "command", label = "alt", #' command = function() tk2theme("alt")) #' if ("aqua" %in% themes) tkadd(themeMenu, "command", label = "aqua", #' command = function() tk2theme("aqua")) #' if ("clam" %in% themes) tkadd(themeMenu, "command", label = "clam", #' command = function() tk2theme("clam")) #' tkadd(themeMenu, "command", label = "clearlooks", #' command = function() tk2theme("clearlooks")) #' if ("classic" %in% themes) tkadd(themeMenu, "command", label = "classic", #' command = function() tk2theme("classic")) #' if ("default" %in% themes) tkadd(themeMenu, "command", label = "default", #' command = function() tk2theme("default")) #' tkadd(themeMenu, "command", label = "keramik", #' command = function() tk2theme("keramik")) #' tkadd(themeMenu, "command", label = "plastik", #' command = function() tk2theme("plastik")) #' tkadd(themeMenu, "command", label = "radiance (fonts change too)!", #' command = function() tk2theme("radiance")) #' if ("vista" %in% themes) tkadd(themeMenu, "command", label = "vista", #' command = function() tk2theme("vista")) #' if ("winnative" %in% themes) tkadd(themeMenu, "command", label = "winnative", #' command = function() tk2theme("winnative")) #' if ("xpnative" %in% themes) tkadd(themeMenu, "command", label = "xpnative", #' command = function() tk2theme("xpnative")) #' tkadd(themeMenu, "separator") #' tkadd(themeMenu, "command", label = "Quit", command = function() tkdestroy(tt)) #' tkadd(topMenu, "cascade", label = "Theme", menu = themeMenu) #' tkfocus(tt) #' } tk2column <- function(widget, action = c("add", "configure", "delete", "names", "cget", "nearest"), ...) { Action <- action[1] tcl(widget, "column", Action, ...) } #' @export #' @rdname tk2commands tk2list.set <- function(widget, items) { # Set a list of values for a widget (e.g., combobox) if (inherits(widget, "tk2combobox")) { # ttk::combobox uses -values parameter tkconfigure(widget, values = as.character(items)) } else { # Try to use the defaul method # First, clear the list tcl(widget, "list", "delete", 0, "end") ## Then, insert all its elements items <- as.character(items) for (item in items) tcl(widget, "list", "insert", "end", item) } } #' @export #' @rdname tk2commands tk2list.insert <- function(widget, index = "end", ...) { # Insert one or more items in a list if (inherits(widget, "tk2combobox")) { # ttk::combobox uses -values parameter Items <- as.character(unlist(list(...))) if (length(Items) < 1) return() # Nothing to insert List <- as.character(tcl(widget, "cget", "-values")) if (length(List) < 2 && List == "") { # The list in empty, simply add these items List <- Items } else if (index == "end" || index > length(List) - 1) { List <- c(List, Items) } else if (index == 0) { # Insert items at the beginning of the list List <- c(Items, List) } else { # Insert items inside the list List <- c(List[1:index], Items, List[(index + 1):length(List)]) } # Reassign this modified list to the combobox tkconfigure(widget, values = List) } else { tcl(widget, "list", "insert", index, ...) } } #' @export #' @rdname tk2commands tk2list.delete <- function(widget, first, last = first) { # Delete one or more items from a list if (inherits(widget, "tk2combobox")) { # ttk::combobox uses -values parameter List <- as.character(tcl(widget, "cget", "-values")) if (length(List) < 2 && List == "") return(List) # The list in empty if (last == "end") last <- length(List) else last <- last + 1 List <- List[-((first + 1):last)] # Reassign this modified list to the combobox tkconfigure(widget, values = List) } else { tcl(widget, "list", "delete", first, last) } } #' @export #' @rdname tk2commands tk2list.get <- function(widget, first = 0, last = "end") { # Get the list of elements in a widget (e.g., combobox) if (inherits(widget, "tk2combobox")) { # ttk::combobox uses -values parameter List <- as.character(tcl(widget, "cget", "-values")) if (length(List) < 2 && List == "") return(List) if (last == "end") last <- length(List) else last <- last + 1 return(List[(first + 1):last]) } else { as.character(tcl(widget, "list", "get", first, last)) } } #' @export #' @rdname tk2commands tk2list.size <- function(widget) { # Get the length of the list of elements in a widget (e.g., combobox) if (inherits(widget, "tk2combobox")) { # ttk::combobox uses -values parameter List <- as.character(tcl(widget, "cget", "-values")) return(length(List)) } else { as.numeric(tcl(widget, "list", "size")) } } #' @export #' @rdname tk2commands tk2state.set <- function(widget, state = c("normal", "disabled", "readonly")) { # Change the state of a widget state <- as.character(state[1]) tkconfigure(widget, state = state) } #' @export #' @rdname tk2commands tk2insert.multi <- function(widget, where = "end", items) { # We insert one or several lines in a multicolumn widget items <- as.matrix(items) # A vector is coerced into a column matrix and we want a row matrix here if (ncol(items) == 1) items <- t(items) # Convert the matrix into [list {el1} {el2} {el3}] [list {el4}, {el5}, {el6}], ... makeTclList <- function(x) paste("[list {", paste(x, collapse = "} {"), "}]", sep = "") TclList <- paste(apply(items, 1, makeTclList), collapse = "\\\n") .Tcl(paste(widget, "insert", where, TclList)) } #' @export #' @rdname tk2commands tk2notetraverse <- function(nb) invisible(tcl("ttk::notebook::enableTraversal", nb)) #' @export #' @rdname tk2commands tk2notetab <- function(nb, tab) { if (inherits(nb, "tk2notebook")) { # We need the tab index, so, look for it ntab <- as.numeric(tcl(nb, "index", "end")) if (ntab < 1) return(NULL) tabidx <- -1 for (i in 0:(ntab - 1)) { if (tclvalue(tcl(nb, "tab", i, "-text")) == tab) { tabidx <- i break } } if (tabidx > -1) { tabid <- paste(nb$ID, tabidx + 1, sep = ".") # Create a simili tkwin object referring to this page w <- list() w$ID <- tabid w$env <- new.env() w$env$num.subwin <- 0 w$env$parent <- nb class(w) <- c("tk2notetab", "tk2container", "tkwin") return(w) } else return(NULL) # Tab not found! } else stop("'nb' must be a 'tk2notebook' object") } #' @export #' @rdname tk2commands tk2notetab.select <- function(nb, tab) { # Select a tab in a notebook if (inherits(nb, "tk2notebook")) { # Tile notebook # We need the tab index, so, look for it ntab <- as.numeric(tcl(nb, "index", "end")) if (ntab < 1) return(invisible(FALSE)) tabidx <- -1 for (i in 0:(ntab - 1)) { if (tclvalue(tcl(nb, "tab", i, "-text")) == tab) { tabidx <- i break } } if (tabidx > -1) { tkselect(nb, tabidx) return(invisible(TRUE)) } else return(invisible(FALSE)) } else stop("'nb' must be a 'tk2notebook' object") } #' @export #' @rdname tk2commands tk2notetab.text <- function(nb) { # Select a tab in a notebook if (inherits(nb, "tk2notebook")) { return(tclvalue(tcl(nb, "tab", "current", "-text"))) } else stop("'nb' must be a 'tk2notebook' object") } # Themes management #' @export #' @rdname tk2commands tk2theme.elements <- function() as.character(.Tcl("ttk::style element names")) #' @export #' @rdname tk2commands tk2theme.list <- function() as.character(.Tcl("ttk::style theme names")) #' @export #' @rdname tk2commands tk2theme <- function(theme = NULL) { if (is.null(theme)) {# Get it res <- getOption("tk2theme") } else {# Set it to theme # First, check if the theme is already loaded... or try loading it loadedThemes <- tk2theme.list() if (!theme %in% loadedThemes) { # Could be plastik, keramik, keramik_alt, clearlooks, radiance res <- try(tclRequire(paste0("ttk::theme::", theme)), silent = TRUE) if (inherits(res, "try-error")) stop("Ttk theme ", theme, " is not found") } # Themes (like radiance) change TkDefaultFont => reset it for the others if (theme == "radiance") { tkfont.configure("TkDefaultFont", family = "Ubuntu", size = 11) } else { tk2font.set("TkDefaultFont", tk2font.get("TkSysDefaultFont")) } # Change theme .Tcl(paste("ttk::style theme use", theme)) # And save current theme in option "tk2theme" options(tk2theme = theme) # Make sure to homogenize background for old tk widgets (suggested by Milan Bouchet-Valat) # Note: foreground not defined for plastik and keramik => workaround fg <- tclvalue(.Tcl("ttk::style lookup TLabel -foreground")) if (fg == "") fg <- "#000000" afg <- tclvalue(.Tcl("ttk::style lookup TLabel -foreground active")) if (afg == "") afg <- "#000000" ffg <- tclvalue(.Tcl("ttk::style lookup TLabel -foreground focus")) if (ffg == "") ffg <- "#000000" hfg <- tclvalue(.Tcl("ttk::style lookup TLabel -foreground hover")) if (hfg == "") hfg <- "#000000" .Tcl(paste("tk_setPalette", "background", tclvalue(.Tcl("ttk::style lookup TLabel -background")), "foreground", fg, "activeBackground", tclvalue(.Tcl("ttk::style lookup TLabel -background active")), "activeForeground", afg, "disabledForeground", tclvalue(.Tcl("ttk::style lookup TLabel -foreground disabled")), "highlightBackground", "white", #tclvalue(.Tcl("ttk::style lookup TLabel -background focus")), "highlightColor", ffg, "insertBackground", afg, "selectBackground", tclvalue(.Tcl("ttk::style lookup TText -selectbackground")), "selectForeground", tclvalue(.Tcl("ttk::style lookup TText -selectforeground")), "selectColor", tclvalue(.Tcl("ttk::style lookup TText -selectforeground")), "throughColor", hfg), "fieldBackground", tclvalue(.Tcl("ttk::style lookup TEntry -fieldbackground"))) # Set menu font the same as label font font <- tclvalue(.Tcl("ttk::style lookup TLabel -font")) if (!length(font) || font == "") font <- "TkDefaultFont" tk2font.set("TkMenuFont", tk2font.get(font)) # Return the theme res <- theme } res } # Note: to change a style element: .Tcl('ttk::style configure TButton -font "helvetica 24"') # Create a derived style: ttk::style configure Emergency.TButton -font "helvetica 24" -foreground red -padding 10 # Changing different states: #ttk::style map TButton \ # -background [list disabled #d9d9d9 active #ececec] \ # -foreground [list disabled #a3a3a3] \ # -relief [list {pressed !disabled} sunken] \ # ; # Function to look for a ttk style #' @export #' @rdname tk2commands tk2style <- function(class, style, state = c("default", "active", "disabled", "focus", "!focus", "pressed", "selected", "background", "readonly", "alternate", "invalid", "hover", "all"), default = NULL) { # Get a ttk style in the current theme # Class is either the TTk class, or the tk2 function name # TODO: add tk2toolbutton and tk2sizegrip! class <- switch(class, tk2button = "TButton", tk2label = "TLabel", tk2toolbutton = "Toolbutton", tk2menubutton = "TMenubutton", tk2checkbutton = "TCheckbutton", tk2radiobutton = "TRadiobutton", tk2entry = "TEntry", tk2combobox = "TCombobox", tk2notebook = "TNotebook", tk2labelframe = "TLabelframe", tk2scrollbar = "TScrollbar", tk2scale = "TScale", tk2progress = "TProgressbar", #tk2spinbox = "TSpinbox", tk2tree = "Treeview", tk2frame = "TFrame", tk2panedwindow = "TPanedwindow", tk2separator = "TSeparator", #"TSizegrip", as.character(class)[1] # Supposed to be the ttk class # Not ttk widgets: tk2canvas, tk2ctext, tk2edit, tk2listbox, # tk2mclistbox, tk2menu, tk2menuentry, tk2spinbox, tk2table ) style = paste("-", as.character(style)[1], sep = "") state = match.arg(state) if (is.null(default)) default <- "" # styles creates a named vector (items in even elements, labels = odd) styles <- function(x) { st <- as.character(x) l <- length(st) if (l == 0) return(character(0)) if (l == 1) return(c(default = st)) if (l %% 2 > 0) stop("Didn't get an even number of items: ", st) stnames <- st[seq(1, l - 1, by = 2)] st <- st[seq(2, l, by = 2)] names(st) <- stnames return(st) } # First look at the map for this class res <- styles(tcl("ttk::style", "map", class, style)) res2 <- styles(tcl("ttk::style", "map", ".", style)) res <- c(res, res2[!names(res2) %in% names(res)]) res2 <- styles(tcl("ttk::style", "configure", class, style)) res <- c(res, res2[!names(res2) %in% names(res)]) res2 <- styles(tcl("ttk::style", "configure", ".", style)) res <- c(res, res2[!names(res2) %in% names(res)]) if (length(res) == 0) res <- c(default = default) # If state != "all", try to resolve the right state if (state != "all") { # If the given state is there, use it if (state %in% names(res)) { return(res[state]) } else if ("default" %in% names(res)) { return(res["default"]) } else { return(c(default = as.character(default)[1])) } } else return(res) } #' @export #' @rdname tk2commands tk2dataList <- function(x) { # List data parameters for a given tk2widget # Data manage the content of the widgets # Common items are label, tag, and tip # image: widgets that can display images # text, textvariable: display text # values, value and selection # command: the command to run # validate, validatecommand, invalidcommand: validation mechanism # variable: varaible associated with value # postcommand: specific to comboboxes, to fill them! # onvalue & offvalue: specific to checkbutton # default: specific for button (default button in a dialog box) # show: specific to entry for password... clash with treeview show => ??? # mode, maximum, value: for progressbars # from, to, increment, : for spinbox & scale + format # Look in text widget what we keep! if (is.tk2widget(x)) cl <- class(x)[1] else cl <- as.character(x)[1] res <- switch(cl, tk2button = c("image", "text", "textvariable", "command", "default"), tk2canvas = character(0), tk2checkbutton = c("image", "text", "textvariable", "variable", "command", "onvalue", "offvalue"), tk2combobox = c("postcommand", "textvariable", "values"), tk2ctext = c("values", "value", "selection", "maxundo", "undo", "spacing1", "spacing2", "spacing3", "tabs", "tabstyle"), # language tk2entry = c("invalidcommand", "textvariable", "validate", "validatecommand", "show"), tk2label = c("image", "text", "textvariable"), tk2labelframe = c("text"), tk2listbox = c("values", "value", "selection"), tk2mclistbox = c("values", "value", "selection"), tk2notebook = character(0), tk2notetab = c("image", "text"), tk2panedwindow = character(0), tk2progress = c("mode", "maximum", "value", "variable"), tk2radiobutton = c("image", "text", "textvariable", "command", "value", "variable"), tk2scale = c("command", "from", "to", "value", "variable"), tk2scrollbar = c("command"), tk2separator = character(0), #tk2sizegrip = character(0), tk2spinbox = c("validate", "validatecommand", "from", "to", "increment", "values", "format", "command"), tk2table = c("values", "value", "selection"), tk2text = c("values", "value", "selection", "maxundo", "undo", "spacing1", "spacing2", "spacing3", "tabs", "tabstyle"), tk2tree = c("values", "value", "selection"), stop("Unknown tk2widget, provide a tk2widget object or its class") ) # Add label, tag & tip for all res <- c(res, "label", "tag", "tip") res } #' @export #' @rdname tk2commands tk2configList <- function(x) { # List config parameters for a given tk2widget # Note: most of the appearance is controlled by the theme, we keep here # only a subset of items that are most useful considering themed widgets: # height, width or length: the size of the widget # compound: how image and text are composed # justify and wrap: control of text flow # orient: for widgets that can be horizontal or vertical # selectmode: for widgets that allow for multiple selections # show: tree and/or headings for the treeview widget if (is.tk2widget(x)) cl <- class(x)[1] else cl <- as.character(x)[1] res <- switch(cl, tk2button = c("compound", "width"), tk2canvas = c("height", "width"), tk2checkbutton = c("compound", "width"), tk2combobox = c("justify", "height", "width"), tk2ctext = c("height", "width"), tk2entry = c("justify", "width"), tk2label = c("compound", "justify", "width", "wraplength"), # Use wrap! tk2labelframe = c("height", "width"), tk2listbox = c("height", "width", "selectmode"), tk2mclistbox = c("height", "width", "selectmode"), tk2notebook = c("height", "width"), tk2notetab = c("compound"), tk2panedwindow = c("orient", "height", "width"), tk2progress = c("length", "orient"), tk2radiobutton = c("compound", "width"), tk2scale = c("length", "orient"), tk2scrollbar = c("orient"), tk2separator = character(0), #tk2sizegrip = character(0), tk2spinbox = c("wrap"), tk2table = c("height", "width"), tk2text = c("height", "width"), tk2tree = c("height", "selectmode", "show"), # show tree and/or headings stop("Unknown tk2widget, provide a tk2widget object or its class") ) # Add cursor and takefocus that are common to all # Should we really add these? #res <- c(res, "cursor", "takefocus") res } # Check if Tk or Ttk are available #' @export #' @rdname tk2commands is.tk <- function() (tclvalue(.Tcl("catch { package present Tk }")) == "0") #' @export #' @rdname tk2commands is.ttk <- function() { (is.tk() && as.numeric(tcl("set", "::tk_version")) >= 8.5) } tcltk2/R/tk2swaplist.R0000644000176200001440000000347514656355210014310 0ustar liggesusers#' A list selector that allows to select and arrange items freely #' #' The swaplist is perfect to select and arrange items in a given order from a #' fixed initial set of possible items. #' #' @param items A vector with all items. #' @param selection A vector with preselected items (must be a subset of `items`). #' @param title The title of the dialog box, by default, "Select items". #' @param ... Further parameters passed to swaplist, see its tcl man page: #' https://core.tcl-lang.org/tklib/doc/trunk/embedded/www/tklib/files/modules/swaplist/swaplist.html. #' #' @return A vector with the selected items in the chosen order. #' @export #' @seealso [tk2listbox()], [tk2tablelist()] #' #' @examples #' \dontrun{ #' library(tcltk2) #' # tk2swaplist() makes its use super-easy #' tk2swaplist(1:9, selection = c(1, 3, 5)) #' #' # Use of the swaplist on your own #' tclRequire("swaplist") #' tt <- tktoplevel() #' opts <- tclVar() #' sl <- tcl("swaplist::swaplist", tt, opts, 1:9, c(1, 3, 5)) #' cat("You choose:", tclvalue(opts), "\n") #' rm(opts, sl, tt) #' } tk2swaplist <- function(items, selection, title = "Select items", ...) { win <- tktoplevel() res <- try(tclRequire("swaplist"), silent = TRUE) if (inherits(res, "try-error")) stop("swaplist Tcl package not available") sel <- tclVar() res <- tcl("swaplist::swaplist", win, sel, items, selection, title = title, ...) if (tclvalue(res) == 0) { # User cancelled res <- character(0) } else { res <- tclObj(sel) } if (is.ordered(items)) return(ordered(as.character(res), levels = levels(items))) if (is.factor(items)) return(factor(as.character(res), levels = levels(items))) switch(typeof(items), integer = as.integer(res), double = as.numeric(res), logical = as.logical(res), complex = as.complex(res), as.character(res) ) } tcltk2/R/tcltk2-Internal.R0000755000176200001440000002750015017047140014764 0ustar liggesusers.onLoad <- function(libname, pkgname) { libdir <- file.path(libname, pkgname, "tklibs") # A slightly modified version of addTclPath() that works also within SciViews addTclPath <- function(path = ".") { if (.Platform$OS.type == "windows") path <- gsub("\\", "/", path, fixed = TRUE) # Modified by GregznaV (Pull Request #2) #a <- tclvalue(tcl("set", "::auto_path")) #paths <- strsplit(a, " ", fixed = TRUE)[[1L]] #paths <- as.character(tcl("set", "::auto_path")) paths <- as.character(tcl("set", "auto_path")) if (!path %in% paths) { tcl("lappend", "auto_path", path) } else { # Added by GregznaV (Pull Request #2) # To have a consistent output if the path is not changed: tcl("set", "auto_path") } invisible(paths) } res <- addTclPath(libdir) # extend the Tcl/Tk path # Load Tcl and Tk translation catalogs res <- tclRequire("msgcat") if (inherits(res, "tclObj")) { .Tcl("namespace import msgcat::*") .Tcl("mcload [file join $::tcl_library msgs]") # In case there is no display available, this fails -> fail silently try(.Tcl("mcload [file join $::tk_library msgs]"), silent = TRUE) # Make sure that Tcl/Tk locale is the same one as current R locale lang <- getLanguage() if (lang != "") { # Set the same language for Tcl/Tk try(setLanguage(lang), silent = TRUE) } } if (is.tk()) { # Here is how we could install the supplementary material in Tcl/Tk # This is for a better management of scrollbars in listbox, text, canvas suppressWarnings(try(tclRequire("autoscroll"), silent = TRUE)) # Version 1.1 try(tcl("source", file.path(libdir, "scrolledWidget.tcl")), silent = TRUE) #tclRequire("choosefont") # Version 0.2 #tclRequire("ctext") # Version 3.1 #tclRequire("cursor") # Version 0.3.1 #tclRequire("mclistbox") # Version 1.2 #tclRequire("swaplist") # Version 0.2 #tclRequire("tablelist") # Version 7.6 #Not provided any more -> tclRequire("Tktable") # Version 2.9 # The following code is not implemented as Tcl package... just source it try(tcl("source", file.path(libdir, "notebook1.3", "notebook.tcl")), silent = TRUE) try(tcl("source", file.path(libdir, "tree1.7", "tree.tcl")), silent = TRUE) # Do we try to load the tile widgets? (only if Tcl./Tk < 8.5) if (as.numeric(tclvalue("::tcl_version")) < 8.5) { ### tcl("source", file.path(libdir, "fonts.tcl")) # Define fonts used in Tk (note: must be done AFTER loading tile!) # Default values for system fonts are calculated by tile... # but they should be computed from the system, actually # We collect back those values calculated by tile and possibly override # them with better values ### tk2font.setstyle(system = TRUE, default.styles = TRUE, text = TRUE) ### TODO: reflect possible changes to other graphical toolkits (how?) } else {# There is a bug in mclistbox with Tcl/Tk 8.5 # Patch by Christiane Raemsch, slightly modified by Ph. Grosjean # This is essentially the listbox procedure, but with an additional # focus argument required by mclistbox .Tcl('proc ::tk::ListboxBeginSelect {w el {focus 0}} { variable ::tk::Priv if {[$w cget -selectmode] eq "multiple"} { if {[$w selection includes $el]} { $w selection clear $el } else { $w selection set $el } } else { $w selection clear 0 end $w selection set $el $w selection anchor $el set Priv(listboxSelection) {} set Priv(listboxPrev) $el } event generate $w <> if {$focus && [winfo exists $w]} { focus $w } }') } # Load additional ttk themes - No: load only on demand! # Not done any more on startup, done on demand in tk2theme() now #try(tclRequire("ttk::theme::plastik"), silent = TRUE) #try(tclRequire("ttk::theme::keramik"), silent = TRUE) #try(tclRequire("ttk::theme::keramik_alt"), silent = TRUE) #try(tclRequire("ttk::theme::clearlooks"), silent = TRUE) #try(tclRequire("ttk::theme::radiance"), silent = TRUE) # Which ttk theme should we use? # If the user specified a default theme, use it if (!.loadTheme()) { # ...otherwise, try to guess the best default value themes <- try(tk2theme.list(), silent = TRUE) if (!inherits(themes, "try-error")) { if ("aqua" %in% themes) { # This must be aquaTk on a Mac try(tk2theme("aqua"), silent = TRUE) } else if ("vista" %in% themes) { # This must be Vista or Win 7 try(tk2theme("vista"), silent = TRUE) } else if ("xpnative" %in% themes) { # This must be XP try(tk2theme("xpnative"), silent = TRUE) } else if ("winnative" %in% themes) { # This must be a pre-XP windows try(tk2theme("winnative"), silent = TRUE) } else if (.isUbuntu()) { #try(tk2theme("radiance"), silent = TRUE) # We also load clearlooks by default in Ubuntu try(tk2theme("clearlooks"), silent = TRUE) # Special treatment for Ubuntu: change fonts to Ubuntu and Ubuntu mono # and use white text on black for tooltips # Again, Tk 8.5/8.6 does a better job by default now than 8.4 # So, we don't need this any more!? #tkfont.configure("TkDefaultFont", family = "Ubuntu", size = 11) #tkfont.configure("TkMenuFont", family = "Ubuntu", size = 11) #tkfont.configure("TkCaptionFont", family = "Ubuntu", size = 10) #tkfont.configure("TkSmallCaptionFont", family = "Ubuntu", size = 9) #tkfont.configure("TkTooltipFont", family = "Ubuntu", size = 9) #tkfont.configure("TkMenuFont", family = "Ubuntu", size = 11) #tkfont.configure("TkHeadingFont", family = "Ubuntu", size = 12) #tkfont.configure("TkIconFont", family = "Ubuntu", size = 11) #tkfont.configure("TkTextFont", family = "Ubuntu", size = 11) #tkfont.configure("TkFixedFont", family = "Ubuntu Mono", size = 11) res <- tclRequire("tooltip") if (inherits(res, "tclObj")) { .Tcl(paste("set ::tooltip::labelOpts [list -highlightthickness 0", "-relief solid -bd 1 -background black -fg white]")) } } else {# A modern "default" theme that fits not too bad in many situations suppressWarnings(try(tk2theme("clearlooks"), silent = TRUE)) } } } # Save default font as TkSysDefaultFont tk2font.set("TkSysDefaultFont", tk2font.get("TkDefaultFont")) } # Windows only if (.Platform$OS.type == "windows") { try(tclRequire("dde"), silent = TRUE) # Version 1.2.2 # Not loaded automatically! #tclRequire("registry") # Version 1.1.3 # Support for winico.dll is drop from version 1.2-1! # if (nzchar(r_arch <- .Platform$r_arch)) # tcl("load", file.path(libname, pkgname, "libs", r_arch, "Winico06.dll")) # else # tcl("load", file.path(libname, pkgname, "libs", "Winico06.dll")) # Also register the DDE server as TclEval|R try(tk2dde("R"), silent = TRUE) } } .onUnload <- function(libpath) { # Remove all currently scheduled tasks tclTaskDelete(id = NULL) } .saveTheme <- function() cat(tk2theme(), "\n", sep = "", file = "~/.Rtk2theme") .loadTheme <- function() { if (file.exists("~/.Rtk2theme")) { theme <- try(readLines("~/.Rtk2theme")[1], silent = TRUE) if (inherits(theme, 'try-error')) return(FALSE) # Try changing the tk2theme according to this value res <- try(tk2theme(theme), silent = TRUE) !inherits(res, "try-error") } else FALSE } .isUbuntu <- function() { # Note: take care not to call 'cat' on Windows: it is usually *not* there! if (.Platform$OS.type == "windows" || grepl("^mac", .Platform$pkgType)) return(FALSE) # This is either Windows or Mac OS X! # On Ubuntu, there is an lsb-release file, but read it just to make sure file.exists("/etc/lsb-release") && any(grepl("[Uu]buntu", readLines("/etc/lsb-release"))) } .mergeList <- function(l1, l2) { # For named lists, overwrite items of l1 present in l2 nms <- names(l2) # Deal with named items if (length(nms)) { named <- nms != "" if (any(named)) { l2n <- l2[named] nmsn <- nms[named] for (i in 1:length(nmsn)) l1[[nmsn[i]]] <- l2n[[nmsn[i]]] } # Keep only non named items in l2 l2 <- l2[!named] } # Deal with non named items in l2 if (length(l2)) { # Unnamed list n1 <- length(l1) n2 <- length(l2) for (i in 1:n2) l1[[n1 + i]] <- l2[[i]] } l1 } .configStd <- function(x, lstval) { # These config parameters are considered as data # Image if (!is.null(lstval$image)) { tkconfigure(x, image = lstval$image) lstval$image <- NULL } # Text if (!is.null(lstval$text)) { tkconfigure(x, text = lstval$text) lstval$text <- NULL } # Textvariable if (!is.null(lstval$textvariable)) { tkconfigure(x, textvariable = lstval$textvariable) lstval$textvariable <- NULL } # Values if (!is.null(lstval$values)) { values(x) <- lstval$values lstval$values <- NULL } # Value if (!is.null(lstval$value)) { value(x) <- lstval$value lstval$value <- NULL } # Selection if (!is.null(lstval$selection)) { selection(x) <- lstval$selection lstval$selection <- NULL } # Label (not a Tk attribute) if (!is.null(lstval$label)) { label(x) <- lstval$label lstval$label <- NULL } # Tag (not a Tk attribute) if (!is.null(lstval$name)) { tag(x) <- lstval$tag lstval$tag <- NULL } # Tooltip if (!is.null(lstval$tip)) { tip(x) <- lstval$tip lstval$tip <- NULL } # Disabled (is tk 'state' parameter indeed) if (!is.null(lstval$disabled)) { disabled(x) <- lstval$disabled lstval$disabled <- NULL } # Return modified value list lstval } .wraplength <- function(w, width) { # Calculate wraplength required for tk2label widgets # width is expressed in characters, but wraplength must be given in pixels # This is stupid and requires additional computation to calculate the # width in pixel of an average character, like "0" to do the conversion! # Get the average size of one character in the current font used # If width is not set, just return a large value for wraplength if (!length(width)) return(1000) # Get the font and measure it font <- tclvalue(tkcget(w, "-font")) if (font == "") font <- tk2style("tk2label", "font") if (font == "") { charsize <- 8 # Use an everage value } else charsize <- as.numeric(tkfont.measure(tkfont.actual(font), "0")) # Optimal wraplength is width * charsize width * charsize } .TempEnv <- function() { pos <- match("SciViews:TempEnv", search()) if (is.na(pos)) { # Must create it `SciViews:TempEnv` <- list() Attach <- function(...) get("attach", mode = "function")(...) Attach(`SciViews:TempEnv`, pos = length(search()) - 1) rm(`SciViews:TempEnv`) pos <- match("SciViews:TempEnv", search()) } pos.to.env(pos) } .assignTemp <- function(x, value, replace.existing = TRUE) if (replace.existing || !exists(x, envir = .TempEnv(), mode = "any", inherits = FALSE)) assign(x, value, envir = .TempEnv()) .getTemp <- function(x, default = NULL, mode = "any", item = NULL) { if (is.null(item)) Mode <- mode else Mode <- "any" if (exists(x, envir = .TempEnv(), mode = Mode, inherits = FALSE)) { dat <- get(x, envir = .TempEnv(), mode = Mode, inherits = FALSE) if (is.null(item)) return(dat) else { item <- as.character(item)[1] if (inherits(dat, "list") && item %in% names(dat)) { dat <- dat[[item]] if (mode != "any" && mode(dat) != mode) dat <- default return(dat) } else { return(default) } } } else {# Variable not found, return the default value return(default) } } tcltk2/R/tk2dde.R0000755000176200001440000002367015017045152013171 0ustar liggesusers#' Use DDE (Dynamic Data Exchange) under Windows #' #' DDE is the first Microsoft's attempt to make an inter-application mechanism. #' It is now superseeded by (D)Com, but it is still available (although declared #' as unsupported). Being simpler than Com, DDE is interesting for simple tasks. #' Applications like Word or Excel provide services one can access through DDE #' (see examples). This code if left for backward compatibility, and also, just #' in case you will find some use of it. But for new projects in general, you #' should not use this any more. #' #' @param topic The 'topic' to reach or expose. A DDE server is accessed as #' service'|'topic'. In the case of [tk2dde()], a non null topic activates #' the DDE server, and a null topic deactivate it. #' @param service The name of the service to reach. In `tk2dde.services`, if #' both service and topic are empty, the list of all available DDE service is #' returned, otherwise, only available topics for a given service are listed. #' @param command A string with the command to run in the external application #' (syntax depends on the server). #' @param async Is a command run asynchroneously (returns immediately, before #' the command is processed), or not? #' @param item The concerned item (usually a variable name, a range in a #' worksheet, etc...). #' @param data The new value for the item. #' @param binary Should the return be treated as binary data or not? #' #' @note #' This is only available under Windows. Trying to use these functions under #' other platforms raises an error. Under Windows, R is automatically configured #' as a DDE server with name 'TclEval|SciViewsR' when this package is loaded. #' #' @export #' @rdname tk2dde #' @author Philippe Grosjean #' @seealso [tk2reg.get()] #' @keywords utilities #' #' @examples #' \dontrun{ #' # These cannot be run by examples() but should be OK when pasted #' # into an interactive R session with the tcltk package loaded #' #' # Examples of DDE - Windows only #' #' ### Examples using wish ### #' # Start a Wish84 console side-by-side with R. #' # (to get wish, you need to install ActiveTcl from #' # http://www.activestate.com/Products/ActiveTcl/) #' # Once it is done, start 'Wish84' from the start menu) #' # Register the Wish console as a DDE server, that is, type in it #' # (% is the Tcl prompt, do not type it!): #' # % package require dde #' # % dde servername wish #' #' ### In R: #' tk2dde("R") # Return 0 if succeed #' tk2dde.services() #' # Evaluate some string in wish #' tk2dde.exec("TclEval", "wish", "{puts {Hello World!}}") #' # Give a value to a variable in wish #' tk2dde.poke("TclEval", "wish", "myvar", "{This is a string!}") #' # Note that you must surround strings with curly braces in Tcl! #' tk2dde.poke("TclEval", "wish", "mynumvar", c(34.56, 78.9)) #' #' # In wish, check that vars exist and have correct value #' # % puts $myvar #' # % puts $mynumvar #' #' # Get the value of one variable from wish into R #' tk2dde.request("TclEval", "wish", "myvar") #' tk2dde.request("TclEval", "wish", "mynumvar") #' # Note that you do not know here if it is a string, a number, or so... #' # You have to know and convert yourself! #' #' # Now, the other way: execute a R function from wish #' # You first need to register a R function for callback #' # (For the moment, only functions without arguments are supported!) #' doDDE <- function() cat("DDE execute!") # A simple function #' tclFun(doDDE) #' # And in wish #' # % dde execute TclEval R doDDE #' #' # Once you have defined a variable using tclVar, you can get or change it #' # from the dde server. However, tclVar gives cryptic names like ::RTcl1. #' # So we prefer to use tclVarName() #' myvar2 <- tclVarName("myvar2", "this is a test...") #' tclvalue(myvar2) # This is the way we access to this variable in R #' #' # In wish you get the value and change it: #' # % dde request TclEval R myvar2 #' # Again, dde poke does not work and must be replaced by an execute command #' # This does not work (???) #' # % dde poke TclEval R myvar2 {yes! and it works...} #' # ... but this is fine #' # % dde execute TclEval R {set myvar2 {yes! and it works...}} #' #' # And in R... #' tclvalue(myvar2) #' #' ### DDE at the command line with execdde.exe ### #' # You can also change the value of a variable, or run a command in R from #' # the command line using execdde.exe: #' # - Download execdde.exe from http://www.sciviews.org/SciViews-R/execdde.zip #' # - Unzip it and copy 'execdde.exe' somewhere in your path, #' # - Start a DOS window #' # - Enter the following commands ('>' is the prompt, do not type it): #' # > execdde -s TclEval -t R -c doDDE > NUL #' # > if errorlevel 1 echo An error occurs... branch accordingly in your batch! #' # > execdde -s TclEval -t R -c "set myvar2 'ok from execdde'" > NUL #' #' # And in R: #' tclvalue(myvar2) #' # Note: thanks to separate event loops, it works also when R calculates... #' #' ### Manipulating Microsoft Excel ### #' # Start Excel with a blank workbook, then... #' #' # Change values in Excel from R: #' tk2dde.poke("Excel", "Sheet1", "R1C1:R2C1", c("5.7", "6.34")) # Some data #' tk2dde.poke("Excel", "Sheet1", "R3C1", "= A1 + A2") # A formula #' #' # Read values in Excel (note that results of formulas are returned) #' Res <- tk2dde.request("Excel", "Sheet1", "R1C1:R3C1") #' Res #' as.numeric(Res) #' #' } tk2dde <- function(topic = NULL) { # Initialize a tcltk dde server with name 'TclEval|topic' .tk2dde.require() # If topic is NULL, just get my server name if (is.null(topic)) return(tclvalue(.Tcl("dde servername {}"))) # Otherwise topic must be character topic <- topic[1] if (!is.character(topic) || topic == "") stop("'topic' must be a non null character string!") # Verify if I am not already registered under this topic if (tclvalue(.Tcl("dde servername {}")) == topic) return(0) # OK # Check that this server name does not exist yet if (length(grep(paste("[{]TclEval ", topic, "[}]", sep = ""), as.character(.Tcl("dde services TclEval {}")))) > 0) return(1) # This server name already exists => return 1 and don't set! # Register me as a dde server with this topic name .Tcl(paste("dde servername", topic)) # Check that the server is set correctly # (if not, return 2 to warn that a problem occurred) if (tclvalue(.Tcl("dde servername {}")) == topic) { return(0) } else { return(2) } } #' @export #' @rdname tk2dde tk2dde.exec <- function(service, topic, command, async = FALSE) { # Execute a command in the 'service|topic' dde server .tk2dde.require() if (!is.character(service) || !is.character(topic) || !is.character(command)) stop("'service', 'topic' and 'command' must be character strings!") if (async[1] == TRUE) async <- "-async" else async <- "" # Execute the command in a try(), to nicely catch the error # class is "try-error" if an error occurs, otherwise, returns "" res <- (try(tclvalue(.Tcl(paste("dde execute ", async, " ", as.character(service[1]), " ", as.character(topic[1]), " ", as.character(command[1]), sep = ""))))) res } #' @export #' @rdname tk2dde tk2dde.poke <- function(service, topic, item, data) { # Set a value (data) to 'item' in the 'service|topic' dde server's app .tk2dde.require() if (!is.character(service) || !is.character(topic)) stop("'service' and 'topic' must be character strings!") if (!is.character(item)) stop("'item' must be character strings!") # In Tcl, if 'data' is a character string, enclose it in curly braces data <- paste("{", paste(as.character(data), collapse = "\n"), "}", sep = "") # For some reasons, dde poke does not seem to work with a TclEval serve... # use dde execute instead if (service == "TclEval") { Cmd <- paste("{set ", as.character(item[1]), " ", data, "}", sep = "") # This would not work with all kind of data!!! # Also, if it is a vector, matrix, or array, it does not work properly! return(tk2dde.exec(service, topic, Cmd, async = TRUE)) } # Poke the data within a try(), to nicely catch the error # class is "try-error" if an error occurs, otherwise, returns "" res <- (try(as.character(.Tcl(paste("dde poke", as.character(service[1]), as.character(topic[1]), as.character(item[1]), data))))) res } #' @export #' @rdname tk2dde tk2dde.request <- function(service, topic, item, binary = FALSE) { # Get the value for 'item' in 'service|topic' dde server .tk2dde.require() if (!is.character(service) || !is.character(topic)) stop("'service' and 'topic' must be character strings!") if (!is.character(item)) stop("'item' must be character strings!") if (binary[1] == TRUE) binary <- "-binary" else binary <- "" # Request the value in a try(), to nicely catch the error # class is "try-error" if an error occurs, otherwise, returns "" res <- (try(as.character(.Tcl(paste("dde request ", binary, " ", as.character(service[1]), " ", as.character(topic[1]), " ", as.character(item[1]), sep = ""))))) res } #' @export #' @rdname tk2dde tk2dde.services <- function(service = "", topic = "") { # List the 'service|topic' dde currently available .tk2dde.require() # Check arguments if (!is.character(service) || !is.character(topic)) stop("'service' and 'topic' must be character strings!") service <- as.character(service[1]) if (service == "") service <- "{}" # This is an empty string in Tcl topic <- as.character(topic[1]) if (topic == "") topic <- "{}" # This is an empty string in Tcl # Get the list of all 'service|topic' dde servers currently running as.character(.Tcl(paste("dde services", service, topic))) } .tk2dde.require <- function() { if (.Platform$OS.type != "windows") stop("This is a Windows-specific function!") # Make sure tcl/tk dde is operational if (!capabilities("tcltk")) stop("This version of R cannot use Tcl/Tk!") res <- tclRequire("dde", warn = TRUE) if (inherits(res, "tclObj")) res <- tclvalue(res) if (res[1] == FALSE) stop("Unable to find the 'dde' Tcl/tk package!") res # The package version number } tcltk2/R/tclVarFun.R0000755000176200001440000001713515017045126013720 0ustar liggesusers# TODO: # - Add a catch {} in tclFun and handle it # - A tclFunDispose() function to delete the Tcl equivalent of a function # - Add a try construct in tclVarExists and tclVarFind # - better manage catch{} in tclVarName #' Manipulate R variables and functions from tcl and back #' #' These functions are intended to provide a better "duality" between the name #' of variables in both R and tcl, including for function calls. It is possible #' to define a variable with the same name in R and tcl (the content is #' identical, but copied and coerced in the two respective environments). It is #' also possible to get the value of a tcl variable from R, and to call a R #' function from within tcl. These features are provided in the tcltk package, #' but Tcl variable usually have different internal names as R equivalents. #' #' @param names Transform names so that they are valid for variables in Tcl. #' @param unique Should these names be unique in the vector? #' @param f An R function. currently, do no support functions with arguments. #' @param name The name of a variable. #' @param value The value to place in a variable. #' @param pattern A pattern to search for. #' @param init Initial value to use when creating the variable. #' @param keep.existing If the tcl variable already exist, should we keep its #' content? #' #' @details #' These functions are similar to [tcltk::tclVar()] from package tcltk, except #' for the following change: here, it is possible to propose a name for the #' created tcl variable, or to set or retrieve the content of a tcl variable #' that is not mirrored in R. #' #' @return #' Most of these functions return a 'tclVar' object. #' @author Philippe Grosjean #' @seealso [tk2edit()], [tcltk::tclVar()] #' @keywords utilities #' @export #' @rdname tclVarFun #' #' @examples #' \dontrun{ #' # These cannot be run by examples() but should be OK when pasted #' # into an interactive R session with the tcltk package loaded #' #' # Tcl functions and variables manipulation #' tclVarExists("tcl_version") #' tclVarExists("probably_non_existant") #' tclVarFind("tcl*") #' #' # Using tclVarName() and tclGetValue()... #' # intented for better match between R and Tcl variables #' Test <- tclVarName("Test", "this is a test!") #' # Now 'Test' exist both in R and in Tcl... In R, you need to use #' tclvalue(Test) # to retrieve its content #' # If a variable already exists in Tcl, its content is preserved using #' # keep.existing = TRUE #' #' # Create a variable in Tcl and assign "just a test..." to it #' tclSetValue("A_Variable", "just to test...") #' # Create the dual variable with same name #' A_Variable <- tclVarName("A_Variable", "something else?") #' tclvalue(A_Variable) # Content of the variable is not changed! #' #' # If you want to retrieve the content of a Tcl variable, #' # but do not want to create a reference to it in R, use: #' #4 # Create a Tcl variable, not visible from R #' tclSetValue("Another_Variable", 1:5) #' tclGetValue("Another_Variable") # Get its content in R (no conversion!) #' tclSetValue("Another_Variable", paste("Am I", c("happy", "sad"), "?")) #' tclGetValue("Another_Variable") # Get its content in R (no conversion!) #' } makeTclNames <- function(names, unique = FALSE) { # Make valid Tcl variable names (allow_ = TRUE by default in R >= 2.0.0) names <- make.names(names, unique = unique) # There is a problem if the variable starts with a dot => prepend it with 'X' .names <- grep("^\\.", names) names[.names] <- paste("X", names[.names], sep = "") # Although it is accepted, there could be problems with variable names # containing dots, so, replace them with '_' gsub("\\.", "_", names) } ### TODO: change this to use closure functions instead!!! #' @export #' @rdname tclVarFun tclFun <- function(f, name = deparse(substitute(f))) { # Register a simple R function (without arguments) as a callback in Tcl, # and give it the same name under Tcl) # Indeed, .Tcl.callback(f) does the job... but it gives criptic names # like R_call 0x13c7168 # Check that 'f' is a function with no arguments (cannot handle them yet) if (!is.function(f)) stop("'f' must be a function!") if (!is.null(formals(f))) stop("The function used cannot (yet) have arguments!") # Make sure the name of the function is valid if (!is.character(name)) stop("'name' must be a character string!") else name <- make.names(name[1]) res <- .Tcl.callback(f) # Make sure this is correct (R_call XXXXXXXX) if (length(grep("R_call ", res) > 0)) { # Create a proc with the same name in Tcl .Tcl(paste("proc ", name, " {} {", res, "}", sep = "")) } # Rem: if you delete the R 'f' function, the Tcl 'f' function still works! # You have to explicitly delete the Tcl function # Return the R_call XXXXXXXX string, as .Tcl.callback() does res } #' @export #' @rdname tclVarFun tclGetValue <- function(name) { # Get the value stored in a plain Tcl variable if (!is.character(name)) stop("'name' must be a character!") name <- makeTclNames(name[1]) # The usual name conversion # Create a temporary dual variable with tclVar() (name does not mather) Temp <- tclVar(init = "") # Copy the content of the var of interest to it res <- tclvalue(.Tcl(paste("catch {set ", as.character(Temp), " $", name, "}", sep = ""))) # Return "0" if OK, "1" otherwise if (res != "0") stop(gettextf("Error when getting the value in the '%s' Tcl variable", name)) # Get the content of the temporary variable tclvalue(Temp) # (Temp will be destroyed when the function exits) } #' @export #' @rdname tclVarFun tclSetValue <- function(name, value) { # This is the opposite of tclGetValue() and it is a wrapper # for 'set name value' Tcl command if (!is.character(name)) stop("'name' must be a character!") name <- makeTclNames(name[1]) # The usual name conversion # Create a temporary dual variable with tclVar() (name does not mather) Temp <- tclVar(init = value) # Copy the content of this variable to the tcl variable 'name' res <- tclvalue(.Tcl(paste("catch {set ", name, " $", as.character(Temp), "}", sep = ""))) if (res != "0") stop(gettextf("Error when changing the value of the '%s' Tcl variable", name)) # (Temp is destroyed when the function exits) invisible(name) # Return the name of the Tcl variable invisibly } #' @export #' @rdname tclVarFun tclVarExists <- function(name) as.integer(tcl("info", "exists", name)) == 1 #' @export #' @rdname tclVarFun tclVarFind <- function(pattern) as.character(tcl("info", "vars", pattern)) #' @export #' @rdname tclVarFun tclVarName <- function(name, init = "", keep.existing = TRUE) { # tclVar gives names like ::RtclX automatically... # We need to define names ourselve. This is what tclVarName does # If keep existing == TRUE and the variable is already defined, then # we keep its content, instead of initializing it with "init" if (!is.character(name)) stop("'name' must be a character!") name <- makeTclNames(name[1]) # Make sure the name is correct # Temporary save potential content of the Tcl variable elsewhere # (catch in case the variable does not exist) if (isTRUE(keep.existing)) .Tcl(paste("catch {set ZZZTempRvariable $", name, "}", sep = "")) # Create the new dual Tcl-R variable l <- list(env = new.env()) assign(name, NULL, envir = l$env) reg.finalizer(l$env, function(env) tcl("unset", ls(env))) class(l) <- "tclVar" tclvalue(l) <- init # Possibly restore the content of the variable, if keep.existing == TRUE if (isTRUE(keep.existing)) { .Tcl(paste("catch {set", name, "$ZZZTempRvariable}")) # Remove the temporary variable .Tcl("unset -nocomplain ZZZTempRvariable") } l } tcltk2/R/tk2dialogs.R0000755000176200001440000001173215017045161014053 0ustar liggesusers#' Additional Tk dialog boxes #' #' Tk dialog boxes to select a font, unicode characters or a list of ordered #' items. #' #' @param ... Further arguments passed to the dialog box. #' @param parent The Tk toplevel dialog box that will be the parent of the #' configuration dialog box. #' @param widget A widget that can accept a unicode character. For #' `tk2unicode_bind()` it must be a `tk2text` or a `tk2entry` widget. #' #' @return #' The selection made in the dialog box if `OK` is clicked, `""` otherwise for #' [tk2chooseFont()]. #' #' The [tk2unicode_select()] dialog pastes the selected unicode character in the #' designed widget, but returns nothing. The [tk2unicode_config()] changes the #' configuration for the unicode composer, but returns nothing. If you decide to #' do so, it saves the config on a file. This is done app-by-app, and the #' default app name is `"R"`. You can change it by setting a different #' value in the option `"tk2app"`, i.e., `options(tk2app = "myApp")`. #' The `tk2unicode_bind()` is also invoked for its side-effect to install #' required bindings to enable the unicode composer engine for the given widget #' and it returns nothing. #' #' @export #' @rdname tk2dialogfonts #' @author Philippe Grosjean #' @seealso [tk2text()], [tk2listbox()], [tk2list.insert()] #' @keywords utilities #' #' @examples #' \dontrun{ #' library(tcltk2) #' # These cannot be run by examples() but should be OK when pasted #' # into an interactive R session with the tcltk package loaded #' #' # Font selection #' tk2chooseFont() #' tk2chooseFont(font = "{courier} 9", title = "Choose a fixed font", #' fonttype = "fixed", style = 4, sizetype = "all") #' tk2chooseFont(font = "Verdana 12 bold italic underline overstrike", #' fonttype = "prop", style = 2, sizetype = "point") #' #' # Easy unicode character entry #' tt <- tktoplevel() #' txt <- tk2text(tt, width = 60, height = 20) #' tkpack(txt) #' e <- tk2entry(tt, width = 50) #' tkpack(e) #' # Get an unicode character for the text widget #' tk2unicode_select(txt) #' # and for the entry widget #' tk2unicode_select(e) #' #' # Bind the composer to both the text and the entry widgets #' # and display the configuration box #' # Once done, try the compose key + m + u, or compose + " + a #' # or any othert sequence in both widgets #' # or hit the compose key twice #' tk2unicode_bind(txt) #' tk2unicode_bind(e) #' tk2unicode_config(tt) #' } tk2chooseFont <- function(...) { if (!is.tk()) stop("Package Tk is required but not loaded") tclRequire("choosefont") # Make sure message translations are correctly loaded try(tcl("mcload", system.file("tklibs", "choosefile", "msgs", package = "tcltk2")), silent = TRUE) tcl("choosefont::choosefont", ...) } # Unicode character input .tk2unicode_file <- function(app = getOption("tk2app", "R")) file.path("~", paste0(".khimrc.", as.character(app)[1])) .tk2unicode_load <- function() { # Try to get current configuration cfg <- try(tcl("::khim::getConfig"), silent = TRUE) if (inherits(cfg, "try-error")) { # Try loading the khim package res <- tclRequire("khim") if (!inherits(res, "tclObj")) return() # If a config file exists, load it now cfgfile <- .tk2unicode_file() if (file.exists(cfgfile)) tcl("source", cfgfile) # finally get the updated config cfg <- tcl("::khim::getConfig") } # Make sure message translations are correctly loaded try(tcl("mcload", system.file("tklibs", "khim", "msgs", package = "tcltk2")), silent = TRUE) tclvalue(cfg) } #' @export #' @rdname tk2dialogfonts tk2unicode_config <- function(parent) { if (!inherits(parent, "tkwin")) stop("'parent' must be a 'tkwin' object") # Make sure khim is loaded and get its current config cfg <- .tk2unicode_load() # Display the configuration dialog box .Tcl(paste0("::khim::getOptions ", parent$ID, ".khim")) # Get the new config and compare it with the old one cfg2 <- tclvalue(tcl("::khim::getConfig")) if (cfg2 != cfg) { # Ask to save the new config msg <- tclmc("Do you want to save this configuration on disk?", domain = "khim") res <- tkmessageBox( message = msg, icon = "question", type = "yesno") if (tclvalue(res) == "yes") { cfgfile <- .tk2unicode_file() cat(cfg2, file = cfgfile) } } } #' @export #' @rdname tk2dialogfonts tk2unicode_select <- function(widget) { .tk2unicode_load() tcl("::khim::FocusAndInsertSymbol", widget$ID) } #' @export #' @rdname tk2dialogfonts tk2unicode_bind <- function(widget) { if (!inherits(widget, c("tk2text", "tk2entry"))) stop("You can bind the unicode composer to tk2text() or tk2entry() widgets only") # Make sure evertything is loaded and configured correctly .tk2unicode_load() # Create the binding if (inherits(widget, "tk2text")) { tkbindtags(widget, paste0(widget$ID , " KHIM Text ", widget$env$parent$ID, " all")) } else {# This must be a tk2entry widget tkbindtags(widget, paste0(widget$ID , " KHIM Entry ", widget$env$parent$ID, " all")) } } tcltk2/R/tk2methods.R0000644000176200001440000002431015017045214014064 0ustar liggesusers#' A series of methods applicable to tk2widget or tk2cfglist objects #' #' Tk2widgets can be used as tcltk widgets, but they propose also an #' object-oriented interaction through these different methods. #' #' @param x A tk2widget object. #' @param ... A series of named arguments corresponding to parameters and values #' to use for the configuration for `tk2cfglist()`, or reserved arguments for #' future use for the other function (not used yet). #' @param value A value to assign to the object's method. #' #' @return #' Depends on the function. The `is.xxx()` function return `TRUE` or `FALSE` if #' the object is of the right class or not. The assignations form return the #' assigned value. The direct form return the item. #' #' @export #' @rdname tk2methods #' @author Philippe Grosjean #' @seealso [tk2button()], [tk2tip()] #' @keywords utilities is.tk2widget <- function(x) return(inherits(x, "tk2widget")) #' @exportS3Method #' @rdname tk2methods print.tk2widget <- function(x, ...) { if (disabled(x)) txt <- " (disabled)" else txt <- "" cat("A tk2widget of class '", class(x)[1], "'", txt, "\n", sep = "") cat("State: ", state(x), "\n", sep = "") cursize <- size(x) if (cursize > 0) cat("Size: ", cursize, "\n", sep = "") val <- value(x) if (!is.null(val)) { cat("Value:\n") print(value(x)) } invisible(x) } #' @export #' @rdname tk2methods tk2cfglist <- function(...) { res <- list(...) class(res) <- c("tk2cfglist", class(res)) res } #' @exportS3Method #' @rdname tk2methods print.tk2cfglist <- function(x, ...) { if (!length(x)) { cat("An empty tk2widget cfglist\n") } else { cat("A tk2widget cfglist with:\n\n") print(unclass(x)) } invisible(x) } #' @export #' @rdname tk2methods state <- function(x, ...) UseMethod("state") #' @exportS3Method #' @rdname tk2methods state.tk2widget <- function(x, ...) { if (any(grepl("-state ", as.character(tkconfigure(x))))) { as.character(tkcget(x, "-state", ...)) } else { "normal" } } # TODO: a state.tk2listbox, because there is no state property defined for it! #' @export #' @rdname tk2methods label <- function(x, ...) UseMethod("label") #' @exportS3Method #' @rdname tk2methods label.tk2widget <- function(x, ...) x$env$label #' @export #' @rdname tk2methods `label<-` <- function(x, value) UseMethod("label<-") #' @export #' @rdname tk2methods `label<-.tk2widget` <- function(x, value) { x$env$label <- as.character(value)[1] x } #' @export #' @rdname tk2methods tag <- function(x, ...) UseMethod("tag") #' @exportS3Method #' @rdname tk2methods tag.tk2widget <- function(x, ...) x$env$tag #' @export #' @rdname tk2methods `tag<-` <- function(x, value) UseMethod("tag<-") #' @export #' @rdname tk2methods `tag<-.tk2widget` <- function(x, value) { x$env$tag <- value x } #' @export #' @rdname tk2methods disabled <- function(x, ...) UseMethod("disabled") #' @exportS3Method #' @rdname tk2methods disabled.tk2widget <- function(x, ...) (state(x) == "disabled") #' @export #' @rdname tk2methods `disabled<-` <- function(x, value) UseMethod("disabled<-") #' @export #' @rdname tk2methods `disabled<-.tk2widget` <- function(x, value) { if (isTRUE(value)) state <- "disabled" else state <- "normal" tkconfigure(x, state = state) x } #' @export #' @rdname tk2methods values <- function(x, ...) UseMethod("values") #' @exportS3Method #' @rdname tk2methods values.tk2widget <- function(x, ...) NULL # Default value, for widgets that do not support this! #' @exportS3Method #' @rdname tk2methods values.tk2listbox <- function(x, ...) as.character(tkget(x, 0, "end")) #' @export #' @rdname tk2methods `values<-` <- function(x, value) UseMethod("values<-") #' @export #' @rdname tk2methods `values<-.tk2widget` <- function(x, value) stop("This tk2widget does not seem to support values") #' @export #' @rdname tk2methods `values<-.tk2listbox` <- function(x, value) { # Save current selection cursel <- selection(x) tclServiceMode(FALSE) on.exit(tclServiceMode(TRUE)) isDisabled <- disabled(x) on.exit(disabled(x) <- isDisabled, add = TRUE) if (isDisabled) disabled(x) <- FALSE # Change items (no attempt to match them -possible future improvement!-) tkdelete(x, 0, "end") for (item in as.character(value)) tkinsert(x, "end", item) # Try to reapply selection for (sel in cursel) tkselection.set(x, sel - 1) x } #' @export #' @rdname tk2methods value <- function(x, ...) UseMethod("value") #' @exportS3Method #' @rdname tk2methods value.tk2widget <- function(x, ...) NULL # Default value is NULL for tk2widgets #' @exportS3Method #' @rdname tk2methods value.tk2listbox <- function(x, ...) values(x)[selection(x)] #' @export #' @rdname tk2methods `value<-` <- function(x, value) UseMethod("value<-") #' @export #' @rdname tk2methods `value<-.tk2widget` <- function(x, value) stop("This tk2widget does not seem to support setting its value") #' @export #' @rdname tk2methods `value<-.tk2listbox` <- function(x, value) { items <- items(x) if (length(items) > 0) selection(x) <- (1:length(items))[items %in% value] x } #' @export #' @rdname tk2methods selection <- function(x, ...) UseMethod("selection") #' @exportS3Method #' @rdname tk2methods selection.tk2widget <- function(x, ...) NULL # For tk2widgets that do not support selection #' @exportS3Method #' @rdname tk2methods selection.tk2listbox <- function(x, ...) (as.integer(tkcurselection(x)) + 1) #' @export #' @rdname tk2methods `selection<-` <- function(x, value) UseMethod("selection<-") #' @export #' @rdname tk2methods `selection<-.tk2widget` <- function(x, value) stop("This tk2widget does not seem to support setting its selection") #' @export #' @rdname tk2methods `selection<-.tk2listbox` <- function(x, value) { # Prepare tclServiceMode(FALSE) on.exit(tclServiceMode(TRUE)) isDisabled <- disabled(x) on.exit(disabled(x) <- isDisabled, add = TRUE) if (isDisabled) disabled(x) <- FALSE # Clear selection only if (is.null(value) || length(value) < 1) { tkselection.clear(x, 0, "end") return(x) } # Check data value <- sort(as.integer(round(value))) if (value[1] < 1) stop("Selections must be indices > 0") if (value[length(value)] > size(x)) return(x) # Change selection tkselection.clear(x, 0, "end") if (tclvalue(tkcget(x, "-selectmode")) == "single" && length(value) > 1) { warning("Single selection mode... only lowest selection used") tkselection.set(x, value[1] - 1) } else { for (sel in value) tkselection.set(x, sel - 1) } if (!isDisabled) tksee(x, value[1] - 1) x } #' @export #' @rdname tk2methods #' @param index The zero-based index of the item to make visible. visibleItem <- function(x, index, ...) UseMethod("visibleItem") #' @exportS3Method #' @rdname tk2methods visibleItem.tk2widget <- function(x, index, ...) stop("This tk2widget does not seems to support the visibleItem method") #' @exportS3Method #' @rdname tk2methods visibleItem.tk2listbox <- function(x, index, ...) { # Index must be a positive integer index <- as.integer(round(index)) if (is.null(index) || length(index) < 1 || index[1] < 1) stop("index must be a postive integer") tksee(x, index[1] - 1) # Because Tcl uses 0-based indices return(NULL) } #' @export #' @rdname tk2methods size <- function(x, ...) UseMethod("size") #' @exportS3Method #' @rdname tk2methods size.tk2widget <- function(x, ...) 0L # By default, a tk2widget has values of zero size (NULL) #' @exportS3Method #' @rdname tk2methods size.tk2listbox <- function(x, ...) as.integer(tksize(x)) #' @export #' @rdname tk2methods config <- function(x, ...) UseMethod("config") #' @exportS3Method #' @rdname tk2methods #' @param cfglist a list containing one or more named items, with the name #' being a Tcl/Tk property and items being the new value for the property. config.tk2widget <- function(x, cfglist, ...) { # Compile a list of arguments args <- list(...) if (!missing(cfglist)) args <- .mergeList(as.list(cfglist, args)) # Prepare an empty object res <- list() class(res) <- c("tk2cfglist", class(res)) # No arguments provided... query a sublist of parameters if (length(args) == 0) { # Return the complete config (but not the data!) params <- tk2configList(x) if (!length(params)) return(res) } else { # Separate named (set) from unnamed (query only) arguments params <- names(args) if (is.null(params)) {# No named arguments, only queries params <- as.character(args) } else { # For those named arguments, change the config res <- (config(x) <- args[params != ""]) # ... and query the others params <- as.character(args[params == ""]) } } # Retrieve values for the queries if (length(params)) { for (i in 1:length(params)) { p <- tclvalue(tkcget(x, paste("-", params[i], sep = ""))) if (!is.null(p) && p != "") res[[params[i]]] <- p } } res } #' @exportS3Method #' @rdname tk2methods config.tk2label <- function(x, cfglist, ...) { # wrap is special here... => how to deal with it??? # TODO... config.tk2widget(x, cfglist, ...) } # TODO: config.tk2listbox() #' @export #' @rdname tk2methods `config<-` <- function(x, value) UseMethod("config<-") #' @export #' @rdname tk2methods `config<-.tk2widget` <- function(x, value) { # The default function deleguates to tkconfigure, except for a few things value <- .configStd(x, value) value$widget <- x do.call(tkconfigure, value) x } #' @export #' @rdname tk2methods `config<-.tk2label` <- function(x, value) { # Standard treatment value <- .configStd(x, value) if (!is.null(value$wrap)) { # wrap is not a ttk option but we use it here for convenience wrap <- value$wrap value$wrap <- NULL } else wrap <- NULL # For the other parameters, apply tkconfigure() with them value$widget <- x do.call(tkconfigure, value) # Do we still have to apply wrap? width <- abs(as.integer(tclvalue(tkcget(x, "-width")))) if (!is.null(wrap)) { if (isTRUE(wrap)) wraplength <- .wraplength(x, width) else wraplength <- 0 tkconfigure(x, wraplength = wraplength) } # Reapply width to get correct text wrapping (bug in ttk::label?) if (length(width)) tkconfigure(x, width = width) x } # TODO: `config<-.tk2listbox` tcltk2/R/tk2ico.R0000755000176200001440000001777715017045203013217 0ustar liggesusers### TODO: implement ::ico::getIconByName, ::ico::getFileIcon & ::ico::writeIcon ### TODO: gif files are acceptable too for tk2ico.set(), example: ### Image <- tclVar() ### tcl("image", "create", "photo", Image, file = "myfile.gif") ### tcl("wm", "iconphoto", tt, Image) instead of tk2ico.set #' Manipulate icons under Windows #' #' Create, load and work with Windows icons. Change icons for Windows. These #' functions are only useful for Windows, but they silently return `NULL` on #' other platforms for writing compatible code (Windows icons instructions can #' be simply ignored). #' #' @param iconfile A file with a .ico, or .exe extension, containing one or more #' Windows icons #' @param file A file having icon resources (.exe, or .dll). #' @param res The name of the resource from where the icon should be extracted. #' @param size Te size of the icon to use. For windows icons, 16 should be fine #' usually. #' @param win A Tk window, or an integer representing the handle (HWND) of a #' foreign window whose icon will be changed (take care, the function returns #' `TRUE` even if the handle is wrong! #' @param icon A icon object. #' #' @return #' An icon object, which is a reference to an image resource in Tcl. Its classes #' are `c("tclObj", "tclIcon")`. Do not forget to destroy it using #' [tk2ico.destroy()] when you do not need it any more! #' If [tk2ico.load()] fails, it returns `NULL` instead of a Tcl object. #' #' @note #' This is Windows-specific. It is implemented using the ico Tcl package. #' #' @export #' @rdname tk2ico #' @author Philippe Grosjean #' @seealso [tk2dde.exec()], [tk2reg.get()] #' @keywords utilities #' #' @examples #' \dontrun{ #' # These cannot be run by examples() but should be OK when pasted #' # into an interactive R session with the tcltk package loaded #' #' ### Examples of tk2ico - icon manipulation under Windows #' tt2 <- tktoplevel() #' # Load a system icon (there are: "application", "asterisk", "error", #' # "exclamation", "hand", "question", "information", "warning", and "winlogo". #' Warn <- tk2ico.load(res = "warning") #' # Change the icon of my window tt2 #' tk2ico.set(tt2, Warn) #' # Do not forget to destroy icon to free resource when not needed any more #' tk2ico.destroy(Warn) #' rm(Warn) #' #' ### Otherwise, the list of icons in a file are: #' tk2ico.list() #' # and for a given icon, the various sizes are: #' tk2ico.sizes(res = 4) #' #' ### One can set icon of a window from an .ico or .exe file directly #' tk2ico.setFromFile(tt, default = file.path(R.home("bin"), "Rgui.exe")) #' #' tk2ico.setFromFile(tt2, system.file("gui", "SciViews.ico", package = "tcltk2")) #' #' ### When done, dispose of the window and clean the workspace #' tkdestroy(tt2) #' rm(tt2) #' } tk2ico.create <- function(iconfile, res = 0, size = 16) { if (length(iconfile) != 1) stop("'iconfile' must be of length one!") if (!file.exists(iconfile <- as.character(iconfile))) stop(gettextf("File '%s' not found!", iconfile)) # Just use tk2ico.load() with different default args) tk2ico.load(file = iconfile, res = res, size = size) } #' @export #' @rdname tk2ico tk2ico.destroy <- function(icon) { if (!is.tk()) return(NULL) if (.Platform$OS.type != "windows") return(NULL) if (!inherits(icon, "tclIcon")) stop("'icon' is not a \"tclIcon\" object!") res <- tclvalue(.Tcl(paste("catch {image delete ", icon, "}", sep = ""))) (res == "0") # Return "0" if OK, "1" otherwise } #' @export #' @rdname tk2ico tk2ico.list <- function(file = "shell32.dll") { # Make sure that the 'ico' package is loaded .tk2ico.require() if (length(file) != 1) stop("'file' must be of length one!") # If the file is not found directly, try using Sys.which() if (!file.exists(file)) { File <- Sys.which(file) if (!file.exists(File)) stop("file '", file, "' not found") } else File <- file cmd <- paste("::ico::icons {", File, "}", sep = "") res <- try(iconlist <- .Tcl(cmd), silent = TRUE) if (inherits(res, "try-error")) # Tcl error message is unreadable! stop("Unable to list the icon resources in 'file'!") as.character(iconlist) } #' @export #' @rdname tk2ico tk2ico.sizes <- function(file = "shell32.dll", res = "application") { # Make sure that the 'ico' package is loaded .tk2ico.require() if (length(file) != 1) stop("'file' must be of length one!") if (length(res) != 1) stop("'res' must be of length one!") # For compatibility reasons, res can be "application", "asterisk", "error", # "exclamation", "hand", "question", "information", "warning" or "winlogo" # but need to be changed into corresponding ID res <- as.character(res)[1] res <- switch(res, application = "154", asterisk = "173", error = "28", exclamation = "154", hand = "29", question = "263", information = "1001", warning = "200", winlogo = "47", res) # If the file is not found directly, try using Sys.which() if (!file.exists(file)) { File <- Sys.which(file) if (!file.exists(File)) stop("file '", file, "' not found") } else File <- file cmd <- paste("::ico::iconMembers {", File, "} ", res, sep = "") res <- try(iconsizes <- .Tcl(cmd), silent = TRUE) if (inherits(res, "try-error")) # Tcl error message is unreadable! stop("Unable to list sizes for the icon resource 'res' in 'file'!") iconsizes <- as.character(iconsizes) iconsizes <- unique(sub("^[^ ]+ ([0-9]+) .+$", "\\1", iconsizes)) as.integer(iconsizes) } #' @export #' @rdname tk2ico tk2ico.load <- function(file = "shell32.dll", res = "application", size = 16) { # Make sure that the 'ico' package is loaded .tk2ico.require() if (length(file) != 1) stop("'file' must be of length one!") if (length(res) != 1) stop("'res' must be of length one!") # For compatibility reasons, res can be "application", "asterisk", "error", # "exclamation", "hand", "question", "information", "warning" or "winlogo" # but need to be changed into corresponding ID res <- as.character(res)[1] res <- switch(res, application = "154", asterisk = "173", error = "28", exclamation = "154", hand = "29", question = "263", information = "1001", warning = "200", winlogo = "47", res) # If the file is not found directly, try using Sys.which() if (!file.exists(file)) { File <- Sys.which(file) if (!file.exists(File)) stop("file '", file, "' not found") } else File <- file # The old winico code! #cmd <- paste("winico load ", res, " {", file, "}", sep = "") cmd <- paste("::ico::getIcon {", File, "} ", res, " -res ", size, sep = "") res <- try(icon <- .Tcl(cmd), silent = TRUE) if (inherits(res, "try-error")) # Tcl error message is unreadable! stop("Unable to load the icon resource, 'file' or 'res' is wrong!") if (inherits(icon, "tclObj")) class(icon) <- c(class(icon), "tclIcon") icon } #' @export #' @rdname tk2ico tk2ico.setFromFile <- function(win, iconfile) { # iconfile can be either an .ico file, or an .exe # This is the simplest way to set a tk window icon tkwm.iconbitmap(win, iconfile) } #' @export #' @rdname tk2ico tk2ico.set <- function(win, icon) { # Integer for win is not supported any more if (inherits(win, "integer")) stop("Integers for argument win are not supported any more in tcltk > 1.2-0") # Make sure that the 'ico' package is loaded .tk2ico.require() if (!inherits(win, "tkwin") || length(win) < 1) stop("'win' is not a \"tkwin\" object") if (!inherits(icon, "tclIcon")) stop("'icon' is not a \"tclIcon\" object!") # Change the icon of a Tk window tcl("wm", "iconphoto", win, icon) } .tk2ico.require <- function() { if (.Platform$OS.type != "windows") stop("This is a Windows-specific function!") # Make sure tcl/tk dde is operational if (!capabilities("tcltk")) stop("This version of R cannot use Tcl/Tk!") if (!is.tk()) stop("Tk is required") res <- tclRequire("ico", warn = TRUE) if (inherits(res, "tclObj")) res <- tclvalue(res) if (res[1] == FALSE) stop("Unable to find the 'ico' Tcl/tk package!") res # The package version number } tcltk2/R/tk2fonts.R0000755000176200001440000002763415017045175013577 0ustar liggesusers#' Manipulate Tk fonts #' #' Get or set fonts used by Tk widgets from within R. #' #' @param font The name of one or several cached Tk font. #' @param what A list of font characteristics to get: 'family', 'size', 'bold', #' italic', 'underline' and/or 'overstrike'. By default, everything except #' underline' and 'overstrike'. #' @param settings Settings of fonts. There are two possible forms: (1) a vector #' of character strings of same length as font with Tk fonts description like #' -family Times -size 12 -weight bold', for instance, or (2) a list of #' font characteristics (list with components 'family', 'size', 'bold', 'italic', #' 'underline' and 'overstrike'). #' @param text Do we synchronise text Tk fonts (text, titles, and fixed-font #' text) with current settings in `.Fonts` inside the `SciViews:TempEnv` #' environment? #' @param system Do we synchronise system Tk fonts (widgets, window caption, #' menus, tooltips, ...) with current system configuration? This is highly #' platform dependent. Currently, system settings are gathered only under #' Windows, thanks to the `winSystemFonts()` function. #' @param default.styles Do we add `.fontsStyleXXX` in the `SciViews:TempEnv` #' environment, where `XXX` is one of the four default styles: 'Classic', #' 'Alternate', 'Presentation' or 'Fancy'. #' #' @return #' [tk2font.get()] retrieves a list with font characteristics (same format #' as the `settings =` argument) for the first Tk font found in its `font =` #' argument, or `""` if the font is not found. [tk2font.set()] changes current #' font settings or, possibly, create the Tk font. #' [tk2font.setstyle()] changes the current Tk fonts settings according to #' actual system and/or text configuration fonts. #' #' @export #' @rdname tk2fonts #' @author Philippe Grosjean #' @seealso [tk2chooseFont()] #' @keywords utilities #' #' @examples #' \dontrun{ #' # These cannot be run by examples() but should be OK when pasted #' # into an interactive R session with the tcltk package loaded #' # Refresh both text and system Tk fonts #' tk2font.setstyle(system = TRUE, default.styles = TRUE) #' # Get characteristics of the default font #' tk2font.get("TkDefaultFont") #' } tk2font.get <- function(font, what = c("family", "size", "bold", "italic")) { # font is the TkFont name to use, in case of several items, other ones # are secondary, tertiary, ... options # what indicate what characteristic of the font to report in the list # 'family', 'size', 'bold', 'italic', 'underline', 'overstrike' (last two rarely used) if (!is.tk()) return("") allTkFonts <- as.character(tkfont.names()) for (fnt in font) { if (fnt %in% allTkFonts) break } if (!fnt %in% allTkFonts) { return("") #if (length(font) == 1) { # stop("'", font, "' is not currently defined in Tk") #} else { # stop("'", paste(font, collapse = "', '"), "' are not currently defined in Tk") #} } fontspec <- as.character(tkfont.configure(fnt)) res <- list() if (length(fontspec) != 12) return(res) # There is a problem here! if ("family" %in% what) res$family <- fontspec[2] if ("size" %in% what) res$size <- as.numeric(fontspec[4]) if ("bold" %in% what) res$bold <- (fontspec[6] == "bold") if ("italic" %in% what) res$italic <- (fontspec[8] == "italic") if ("underline" %in% what) res$underline <- (fontspec[10] == "1") if ("overstrike" %in% what) res$overstrike <- (fontspec[12] == "1") res } #' @export #' @rdname tk2fonts tk2font.set <- function(font, settings) { ### TODO: allow for multiple fonts specifications => take first one available # font is the name of the TkFont to create/change # settings is a list with font characteristics if (!is.tk()) return(NULL) font <- as.character(font) l <- length(font) if (!is.list(settings) && !is.character(settings)) stop("'settings' must be a list or a character string") # If settings is a character string, # it is assumed to be a text description of a Tk font if (is.character(settings)) { # Do not recycle... make sure that lengths match if (length(settings) != l) stop("length of 'font' and 'settings' do not match") for (i in 1:l) { .Tcl(paste("catch {font create ", font[i], "}", sep = "")) .Tcl(paste("catch {font configure ", font[i], " ", settings[i], "}", sep = "")) } } else {# This is a list of font characteristics # Do not recycle... make sure that lengths match if (l > 1) { if (length(settings) != l) stop("length of 'font' and 'settings' do not match") } else {# Is it the list of characteristics, or a lit containing it? if (any(names(settings) %in% c("family", "size", "bold", "italic", "underline", "overstrike"))) settings <- list(settings) } fntfamilies <- as.character(tkfont.families()) for (i in 1:l) { # Construct the font descriptor fntl <- as.list(settings[[i]]) fnt <- " " if (!is.null(fntl$family)) { # Look for the first font family provided that is available fntfamily <- fntl$family if (length(fntfamily) > 1) { fntexists <- fntfamily %in% fntfamilies if (any(fntexists)) { fntfamily <- fntfamily[fntexists][1] } else { fntfamily <- fntfamily[1] # No fonts found... take first one } } fnt <- paste(fnt, "-family {", fntfamily, "}", sep = "") } if (!is.null(fntl$size)) fnt <- paste(fnt, "-size", fntl$size) if (!is.null(fntl$bold)) { value <- if (fntl$bold == TRUE) "bold" else "normal" fnt <- paste(fnt, "-weight", value) } if (!is.null(fntl$italic)) { value <- if (fntl$italic == TRUE) "italic" else "roman" fnt <- paste(fnt, "-slant", value) } if (!is.null(fntl$underline)) fnt <- paste(fnt, "-underline", as.numeric(fntl$underline == TRUE)) if (!is.null(fntl$overstrike)) fnt <- paste(fnt, "-overstrike", as.numeric(fntl$overstrike == TRUE)) # Possibly create the font in Tk .Tcl(paste("catch {font create ", font[i], "}", sep = "")) if (fnt != " ") .Tcl(paste("catch {font configure ", font[i], fnt, "}", sep = "")) } } res <- font %in% as.character(tkfont.names()) names(res) <- font res } #' @export #' @rdname tk2fonts tk2font.setstyle <- function(text = TRUE, system = FALSE, default.styles = FALSE) { # Set default fonts according to currently defined style # .SystemFonts and .Fonts must be defined in SciViews:TempEnv! if (!is.tk()) { warning("Package Tk is required but not loaded") return(NULL) } # This is a copy of assignTemp(), getTemp() and existsTemp() functions from # svMisc, so that we do not link to this package TempEnv <- function() { pos <- match("SciViews:TempEnv", search()) if (is.na(pos)) { # Must create it `SciViews:TempEnv` <- list() Attach <- function(...) get("attach", mode = "function")(...) Attach(`SciViews:TempEnv`, pos = length(search()) - 1) rm(`SciViews:TempEnv`) pos <- match("SciViews:TempEnv", search()) } pos.to.env(pos) } assignTemp <- function(x, value, replace.existing = TRUE) if (replace.existing || !exists(x, envir = TempEnv(), mode = "any", inherits = FALSE)) assign(x, value, envir = TempEnv()) existsTemp <- function(x, mode = "any") exists(x, envir = TempEnv(), mode = mode, inherits = FALSE) getTemp <- function(x, default = NULL, mode="any") { if (exists(x, envir = TempEnv(), mode = mode, inherits = FALSE)) { return(get(x, envir = TempEnv(), mode = mode, inherits = FALSE)) } else {# Variable not found, return the default value return(default) } } if (system) {# Set system fonts # We collect back system fonts settings (other values may be imposed by Tk) defaultclassic <- tk2font.get("TkClassicDefaultFont") if (defaultclassic == "") defaultclassic <- tk2font.get("TkDefaultFont") sysfonts <- list( defaultclassic = defaultclassic, default = tk2font.get("TkDefaultFont"), caption = tk2font.get("TkCaptionFont"), smallcaption = tk2font.get(c("TkSmallCaptionFont", "TkCaptionFont")), menu = tk2font.get(c("TkMenuFont", "TkDefaultFont")), status = tk2font.get(c("TkStatusFont", "TkTooltipFont")), tooltip = tk2font.get("TkTooltipFont"), heading = tk2font.get("TkHeadingFont"), icon = tk2font.get(c("TkIconFont", "TkDefaultFont")) ) # Make sure these are correctly defined assignTemp(".SystemFonts", sysfonts) res <- TRUE } else res <- character(0) if (default.styles) {# Define default styles # These are the four default Font themes one can use assignTemp(".FontsStyleClassic", list( Text = list(family = c("Times New Roman", "Times"), size = -12), Title = list(family = c("Arial", "Helvetica"), size = -14, bold = TRUE), BigTitle = list(family = c("Arial", "Helvetica"), size = -16, bold = TRUE), Fixed = list(family = c("Courier New", "Courier"), size = -12) )) assignTemp(".FontsStyleAlternate", list( Text = list(family = "Georgia", alt.family = "Times", size = -12), Title = list(family = c("Trebuchet MS", "Trebuchet"), alt.family = "Helvetica", size = -14, bold = TRUE), BigTitle = list(family = c("Trebuchet MS", "Trebuchet"), alt.family = "Helvetica", size = -16, bold = TRUE), Fixed = list(family = "Andale Mono", alt.family = "Courier", size = -12) )) assignTemp(".FontsStylePresentation", list( Text = list(family = "Verdana", alt.family = "Helvetica", size = -12), Title = list(family = "Verdana", alt.family = "Helvetica", size = -14, bold = TRUE), BigTitle = list(family = "Verdana", alt.family = "Helvetica", size = -16, bold = TRUE), Fixed = list(family = "Lucida Console", alt.family = "Courier", size = -12) )) assignTemp(".FontsStyleFancy", list( Text = list(family = c("Trebuchet MS", "Trebuchet"), alt.family = "Helvetica", size = -12), Title = list(family = c("Comic Sans MS", "Comic Sans"), alt.family = "Helvetica", size = -14, bold = TRUE), BigTitle = list(family = c("Comic Sans MS", "Comic Sans"), alt.family = "Helvetica", size = -16, bold = TRUE), Fixed = list(family = "Lucida Console", alt.family = "Courier", size = -12) )) } if (text) {# Set text, titles and fixed fonts # Determine which font style we currently use curStyle <- getTemp(".FontsStyle", default = "Classic", mode = "character") curSFonts <- getTemp(paste(".FontsStyle", curStyle, sep = ""), default = getTemp(".FontsStyleClassic")) assignTemp(".Fonts", curSFonts) # Create corresponding fonts in Tk (note, we create bold, italic, and # bolditalic equivalents for TkTextFont and TkFixedFont Fonts <- list() Fonts$Text <- curSFonts$Text Fonts$Text$bold <- FALSE Fonts$Text$italic <- FALSE Fonts$TextBold <- Fonts$Text Fonts$TextBold$bold <- TRUE Fonts$TextItalic <- Fonts$Text Fonts$TextItalic$italic <- TRUE Fonts$TextBoldItalic <- Fonts$TextBold Fonts$TextBoldItalic$italic <- TRUE Fonts$Title <- curSFonts$Title Fonts$BigTitle <- curSFonts$BigTitle Fonts$Fixed <- curSFonts$Fixed Fonts$Fixed$bold <- FALSE Fonts$Fixed$italic <- FALSE Fonts$FixedBold <- Fonts$Fixed Fonts$FixedBold$bold <- TRUE Fonts$FixedItalic <- Fonts$Fixed Fonts$FixedItalic$italic <- TRUE Fonts$FixedBoldItalic <- Fonts$FixedBold Fonts$FixedBoldItalic$italic <- TRUE FNames <- c("TkTextFont", "TkTextBoldFont", "TkTextItalicFont", "TkTextBoldItalicFont", "TkTitleFont", "TkBigTitleFont", "TkFixedFont", "TkFixedBoldFont", "TkFixedItalicFont", "TkFixedBoldItalicFont") res <- c(res, tk2font.set(FNames, Fonts)) } # Check the results if (system && any(!res)) warning("One or several Tk fonts not set: '", paste(names(res)[!res], collapse = "', '", "'")) res } tcltk2/LICENSE.note0000644000176200001440000001140515017100763013427 0ustar liggesusersThere are different licenses for different parts of this package: - For the R code and most Tcl code license is: GNU Lesser General Public License Version 3 - For the combobox2.3 and mclistbox1.02 Tk Widgets: Combobox version 2.3 Copyright (c) 1998-2003, Bryan Douglas Oakley All Rights Reserved. Mclistbox version 1.02 Copyright (c) 1999, Bryan Douglas Oakley All Rights Reserved. This software is provided AS-IS with no waranty expressed or implied. This software may be used free of charge, though I would appreciate it if you give credit where credit is due and mention my name when you use it. - For the Tk Widgets, Tcllib and Tklib items: The following terms apply to all files associated with the software unless explicitly disclaimed in individual files. The authors hereby grant permission to use, copy, modify, distribute, and license this software and its documentation for any purpose, provided that existing copyright notices are retained in all copies and that this notice is included verbatim in any distributions. No written agreement, license, or royalty fee is required for any of the authorized uses. Modifications to this software may be copyrighted by their authors and need not follow the licensing terms described here, provided that the new terms are clearly indicated on the first page of each file where they apply. IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. GOVERNMENT USE: If you are acquiring this software on behalf of the U.S. government, the Government shall have only "Restricted Rights" in the software and related documentation as defined in the Federal Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you are acquiring the software on behalf of the Department of Defense, the software shall be classified as "Commercial Computer Software" and the Government shall have only "Restricted Rights" as defined in Clause 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the authors grant the U.S. Government and others acting in its behalf permission to use and distribute the software in accordance with the terms specified in this license. - For ctext: This software is copyrighted by George Peter Staplin. The following terms apply to all files associated with the software unless explicitly disclaimed in individual files. The authors hereby grant permission to use, copy, modify, distribute, and license this software and its documentation for any purpose, provided that existing copyright notices are retained in all copies and that this notice is included verbatim in any distributions. No written agreement, license, or royalty fee is required for any of the authorized uses. Modifications to this software may be copyrighted by their authors and need not follow the licensing terms described here, provided that the new terms are clearly indicated on the first page of each file where they apply. IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - For tree: I am D. Richard Hipp, the author of this code. I hereby disavow all claims to copyright on this program and release it into the public domain. - For tablelist: Multi-column listbox and tree widget package Tablelist, version 7.6 Copyright (c) 2000-2019 Csaba Nemethi (E-mail: csaba.nemethi@t-online.de) This library is free software; you can use, modify, and redistribute it for any purpose, provided that existing copyright notices are retained in all copies and that this notice is included verbatim in any distributions. This software is distributed WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. tcltk2/vignettes/0000755000176200001440000000000015017102465013466 5ustar liggesuserstcltk2/vignettes/tcltk2.Rmd0000644000176200001440000000073314656355210015346 0ustar liggesusers--- title: "Tcl/Tk Additions" author: "Philippe Grosjean (phgrosjean@sciviews.org)" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: fig_caption: yes vignette: > %\VignetteIndexEntry{Tcl/Tk Additions} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r setup, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` > The {tcltk2} package provides many supplements to R through Tcl functions and Tk widgets. tcltk2/NAMESPACE0000644000176200001440000001131715017041713012676 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method("config<-",tk2label) S3method("config<-",tk2widget) S3method("disabled<-",tk2widget) S3method("label<-",tk2widget) S3method("selection<-",tk2listbox) S3method("selection<-",tk2widget) S3method("tag<-",tk2widget) S3method("tip<-",tk2widget) S3method("value<-",tk2listbox) S3method("value<-",tk2widget) S3method("values<-",tk2listbox) S3method("values<-",tk2widget) S3method(config,tk2label) S3method(config,tk2widget) S3method(disabled,tk2widget) S3method(label,tk2widget) S3method(print,tclTask) S3method(print,tk2cfglist) S3method(print,tk2widget) S3method(selection,tk2listbox) S3method(selection,tk2widget) S3method(size,tk2listbox) S3method(size,tk2widget) S3method(state,tk2widget) S3method(tag,tk2widget) S3method(tip,tk2widget) S3method(value,tk2listbox) S3method(value,tk2widget) S3method(values,tk2listbox) S3method(values,tk2widget) S3method(visibleItem,tk2listbox) S3method(visibleItem,tk2widget) export("config<-") export("disabled<-") export("label<-") export("selection<-") export("tag<-") export("tip<-") export("value<-") export("values<-") export(config) export(disabled) export(getLanguage) export(is.tk) export(is.tk2widget) export(is.ttk) export(label) export(makeTclNames) export(selection) export(setLanguage) export(size) export(state) export(tag) export(tclAfter) export(tclAfterCancel) export(tclAfterInfo) export(tclFun) export(tclGetValue) export(tclSetValue) export(tclTaskChange) export(tclTaskDelete) export(tclTaskGet) export(tclTaskRun) export(tclTaskSchedule) export(tclVarExists) export(tclVarFind) export(tclVarName) export(tclmc) export(tclmclocale) export(tclmcset) export(tip) export(tk2button) export(tk2canvas) export(tk2cfglist) export(tk2checkbutton) export(tk2chooseFont) export(tk2column) export(tk2combobox) export(tk2configList) export(tk2ctext) export(tk2dataList) export(tk2dde) export(tk2dde.exec) export(tk2dde.poke) export(tk2dde.request) export(tk2dde.services) export(tk2edit) export(tk2entry) export(tk2font.get) export(tk2font.set) export(tk2font.setstyle) export(tk2frame) export(tk2ico.create) export(tk2ico.destroy) export(tk2ico.list) export(tk2ico.load) export(tk2ico.set) export(tk2ico.setFromFile) export(tk2ico.sizes) export(tk2insert.multi) export(tk2killtip) export(tk2label) export(tk2labelframe) export(tk2list.delete) export(tk2list.get) export(tk2list.insert) export(tk2list.set) export(tk2list.size) export(tk2listbox) export(tk2mclistbox) export(tk2menu) export(tk2menubutton) export(tk2message) export(tk2notebook) export(tk2notetab) export(tk2notetab.select) export(tk2notetab.text) export(tk2notetraverse) export(tk2panedwindow) export(tk2progress) export(tk2radiobutton) export(tk2reg.broadcast) export(tk2reg.delete) export(tk2reg.deletekey) export(tk2reg.get) export(tk2reg.keys) export(tk2reg.set) export(tk2reg.setkey) export(tk2reg.type) export(tk2reg.values) export(tk2scale) export(tk2scrollbar) export(tk2separator) export(tk2spinbox) export(tk2state.set) export(tk2style) export(tk2swaplist) export(tk2table) export(tk2tablelist) export(tk2text) export(tk2theme) export(tk2theme.elements) export(tk2theme.list) export(tk2tip) export(tk2tree) export(tk2unicode_bind) export(tk2unicode_config) export(tk2unicode_select) export(value) export(values) export(visibleItem) importFrom(tcltk,"tclvalue<-") importFrom(tcltk,.Tcl) importFrom(tcltk,.Tcl.callback) importFrom(tcltk,as.tclObj) importFrom(tcltk,tcl) importFrom(tcltk,tclArray) importFrom(tcltk,tclObj) importFrom(tcltk,tclRequire) importFrom(tcltk,tclServiceMode) importFrom(tcltk,tclVar) importFrom(tcltk,tclvalue) importFrom(tcltk,tkactivate) importFrom(tcltk,tkadd) importFrom(tcltk,tkbind) importFrom(tcltk,tkbindtags) importFrom(tcltk,tkbutton) importFrom(tcltk,tkcget) importFrom(tcltk,tkconfigure) importFrom(tcltk,tkcurselection) importFrom(tcltk,tkdelete) importFrom(tcltk,tkdestroy) importFrom(tcltk,tkfocus) importFrom(tcltk,tkfont.actual) importFrom(tcltk,tkfont.configure) importFrom(tcltk,tkfont.families) importFrom(tcltk,tkfont.measure) importFrom(tcltk,tkfont.names) importFrom(tcltk,tkget) importFrom(tcltk,tkgrab.set) importFrom(tcltk,tkgrid) importFrom(tcltk,tkgrid.columnconfigure) importFrom(tcltk,tkgrid.configure) importFrom(tcltk,tkgrid.rowconfigure) importFrom(tcltk,tkindex) importFrom(tcltk,tkinsert) importFrom(tcltk,tklabel) importFrom(tcltk,tkmessageBox) importFrom(tcltk,tkscrollbar) importFrom(tcltk,tksee) importFrom(tcltk,tkselect) importFrom(tcltk,tkselection.clear) importFrom(tcltk,tkselection.set) importFrom(tcltk,tkset) importFrom(tcltk,tksize) importFrom(tcltk,tktag.configure) importFrom(tcltk,tktoplevel) importFrom(tcltk,tkwait.window) importFrom(tcltk,tkwidget) importFrom(tcltk,tkwm.iconbitmap) importFrom(tcltk,tkwm.title) importFrom(tcltk,tkxview) importFrom(tcltk,tkyview) tcltk2/inst/0000755000176200001440000000000015017102465012433 5ustar liggesuserstcltk2/inst/CITATION0000644000176200001440000000117015017045042013564 0ustar liggesusersbibentry("Misc", title = "SciViews-R", author = person("Philippe", "Grosjean", role = "aut"), organization = "UMONS", address = "MONS, Belgium", year = version$year, url = "https://www.sciviews.org/SciViews-R/", mheader = "To cite SciViews-R in publications use:", mfooter = paste( "We have invested a lot of time and effort in creating SciViews-R,", "please cite it when using it together with R.", "See also", sQuote("citation(\"pkgname\")"), "for citing R packages.", sep = " ") ) tcltk2/inst/po/0000755000176200001440000000000014656355210013057 5ustar liggesuserstcltk2/inst/po/fr/0000755000176200001440000000000014656355210013466 5ustar liggesuserstcltk2/inst/po/fr/LC_MESSAGES/0000755000176200001440000000000014656355210015253 5ustar liggesuserstcltk2/inst/po/fr/LC_MESSAGES/R-tcltk2.mo0000755000176200001440000001060414656355210017216 0ustar liggesusersÞ•#4/L !!?!a!ƒ,¥"Òõ1C-`0Ž;¿,û*("S=v;´5ð/&6V52Ã&ö0N1c.•$Ä$é(-7;e¡¶G 'd %Œ +² 0Þ / +? +k <— &Ô 0û =, Hj 6³ 5ê # DD g‰ Lñ :>NyNÈ@?X9˜Ò?í=-,k)˜/Â3òH&o!   " # 'f' must be a function!'file' must be of length one!'icon' is not a "tclIcon" object!'iconfile' must be of length one!'item' must be character strings!'leftmenu' must be a "tkwin" object or NULL!'name' must be a character string!'name' must be a character!'pos' must be numeric and of length one, or NULL!'res' must be of length one!'rightmenu' must be a "tkwin" object or NULL!'service' and 'topic' must be character strings!'service', 'topic' and 'command' must be character strings!'topic' must be a non null character string!'value' must be numeric and of length one!'value' must not be empty or NULL!'win' is not a "tkwin" object, or an integer (Window handle)!Error creating the icon resource; probably wrong 'iconfile'Error getting the icon handle for a "tclIcon" object!Error getting the text associated with an icon!Error when changing the value of the '%s' Tcl variableError when getting the value in the '%s' Tcl variableError while changing default position of the icon!Error while changing text of the icon!Error while creating the callback for this icon!File '%s' not found!Impossible to retrieve icon resource information!The function used cannot (yet) have arguments!This is a Windows-specific function!This version of R cannot use Tcl/Tk!Unable to find the 'dde' Tcl/tk package!Unable to find the 'registry' Tcl/tk package!Unable to load the icon resource, 'file' or 'res' is wrong!Unrecognized 'type'!Project-Id-Version: tcltk2 POT-Creation-Date: PO-Revision-Date: 2007-01-03 09:47+0100 Last-Translator: Philippe Grosjean Language-Team: Ph. Grosjean MIME-Version: 1.0 Content-Type: text/plain; charset=iso-8859-1 Content-Transfer-Encoding: 8bit Plural-Forms: nplurals=2; plural=(n > 1); X-Poedit-Language: French X-Poedit-SourceCharset: iso-8859-1 'f' doit être une fonction !'file' doit être de longueur unitaire !'icon' n'est pas un objet "tclIcon" !'iconfile' doit être de longueur unitaire !'item' doit contenir des chaînes de caractères !'leftmenu' doit être un objet "tkwin" ou NULL !'name' doit être une chaîne de caractères !'name' doit être une chaîne de caractères !'pos' doit être numérique et de longueur unitaire, ou NULL !'res' doit être de longueur unitaire !'rightmenu' doit être un objet "tkwin" ou NULL !'service' et 'topic' doivent être des chaînes de caractères !'service', 'topic' et 'command' doivent être des chaînes de caractères !'topic' doit être une chaîne de caractères non nulle !'value' doit être numérique et de longueur unitaire !'value' ne peut être vide ou NULL !'win' n'est pas un objet "tkwin", ou un entier (handle de fenêtre) !Erreur lors de la création de la ressource d'icône ; 'iconfile' est probablement corrompu ou incorrect Erreur lors de la récupération du pointeur d'icône pour un objet "tclIcon" !Erreur lors de la lecture du texte associé à cette icône !Erreur lors de la modification de la valeur contenue dans la variable Tcl '%s'Erreur lors de la récupération de la valeur contenue dans la variable Tcl '%s'Erreur lors du changement de la position par défaut de l'icône !Erreur lors de la modification du texte associé à cette icône !Erreur lors de la création du callback pour cette icône !Fichier '%s' introuvable !Impossible de récupérer l'information de la ressource d'icône !La fonction utilisée ne peut pas (encore) avoir d'arguments !Ceci est une fonction spécifique à Windows !Cette version de R n'utilise pas Tcl/Tk !Impossible de trouver le package Tcl/Tk 'dde' !Incapable de trouver la package Tcl/Tk 'registry' !Incapable de charger la ressource d'icône, 'file' ou 'res' est erronné !'type' non reconnu !tcltk2/inst/doc/0000755000176200001440000000000015017102465013200 5ustar liggesuserstcltk2/inst/doc/tcltk2.html0000644000176200001440000001174615017102465015302 0ustar liggesusers Tcl/Tk Additions

Tcl/Tk Additions

Philippe Grosjean ()

2025-06-01

The {tcltk2} package provides many supplements to R through Tcl functions and Tk widgets.

tcltk2/inst/doc/tcltk2.Rmd0000644000176200001440000000073314656355210015060 0ustar liggesusers--- title: "Tcl/Tk Additions" author: "Philippe Grosjean (phgrosjean@sciviews.org)" date: "`r Sys.Date()`" output: rmarkdown::html_vignette: fig_caption: yes vignette: > %\VignetteIndexEntry{Tcl/Tk Additions} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r setup, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` > The {tcltk2} package provides many supplements to R through Tcl functions and Tk widgets. tcltk2/inst/doc/tcltk2.R0000644000176200001440000000021715017102465014526 0ustar liggesusers## ----setup, include = FALSE--------------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) tcltk2/inst/gui/0000755000176200001440000000000014656355210013225 5ustar liggesuserstcltk2/inst/gui/SciViews.gif0000755000176200001440000000553614656355210015464 0ustar liggesusersGIF89add÷ÿÿÿƒƒƒƒƒÿÿÿ{½{ÿÿƒƒææͽ{½æÍ惃1œ1œ1œ½½{œœ1öÞÞbb¤¤J´´bÍæÍ‹‹ƒööÅÞîîÕ¤Õææ´b´îîÍÍÕÕ¤ÅŤդœ1¤¤Õ”‹‹½½11j½½‹‹½ÕÕœœÍ´´öö¬¤J¤b´b{{””´´æ¤î{{´‹‹‹ÞÞ¬¬AA99ZZÕÕjj¤¤{A¬¬ZRRRÅÅRR9ƒsööÍÞÍÞjj””bbœœJJssææZZssbÕÍÕJsÿÿÍÍÿÿ¬{¤{ÅÿÅÍÞÍb‹Jœ{œbbÕÕ{ÍÕÍAAÿÍ”´‹RƒssRÞ½Í{æ{ƒsR)RjJsJƒZ9´´ƒ)RÍ1Ísœ1JÍJRæRƒ1b11”1îîÍÕ{Õœjœ1ÿ1¤½¤½½9J¬JÿÿRÿRîîî¤î9ƒîÍîÿ{¬{ÿjÿbbJÿÿ9{Õ{s¤J1j1ööîÍÍ{1æ1jJj ƒ)R)jj¤¤””9)‹öÍöÿRÿÿ)ÿ¬{¬{ÿ{ÿ9ÿ9ƒ{ööJÿÿJ¬¤”1s1sJs1Z1sœssƒ‹¬‹‹1‹ÿ ÿAƒ´î´½J½‹‹Rÿÿæ{æöö¤ÕÕ ZZbƒ9ÿ9ÍÍ1ƒbƒbÿÿöö1´J´´sœ1¤1sbæbæÞÞÍRÞÞœÿœÍöÍsRsbƒbîîsÍÍjÞÞ¤99RRÿÿ{J{œ½½¤Z”9ƒ9ƒA9ZÿZƒJƒ‹‹bA{AJJ¤¤‹‹ÕÕb½1½½¬”ööŽb1b¤b¤ƒ9A””ææ{ƒƒjj‹œ1ÅÅ{ÅÅJ{Í{ÞJÞææÕ1Õƒ)jJ”JæJæͤÍ!ù ÿ,ddþÿ H° Áƒ*\È°¡Ã‡#JœH±¢Å‹3jÜȱ£Ç CŠI²¤É“(Sª\ɲ¥Ë—0cÊœI³¦Í›8GVÉiòW«5@€è¬ O®(]z K >׎rDÆ”iŒ(;šÔ“š1iÕMˆû€«E3UÔ2¶m€ ÌN´Tõ0·xËFTpÃÁ€>,¨YÓ^–Öí;„ n!ÄmøÁ_8`À`ðÌx†™š1Ó*P§Ý"˜œPå Èž½ÙsLt¡—2bÔK-ˆ!X±p™c,ÜÀ öìç0Ï´7¤FZßÀ I… „¶z þ.°|ºù:ÈlS¦ËRëB–qÑò(òTOÐ5ƒæxÁ 2q²C{ 5ÄWÑ'ƒ\xáÅ(²=€Y)ÀܸÜLæìE 10Ã| ‘Ã^$ÁÉl"\(Ö^Àa‡æihÛK(±ƒ @FáÂY=¸â`QÈs È@܈#t* “39`¡Ä–;lù`GN1æ5)uL`•3“DqB…X9$dððQE€uP!ÖjjR9À4UÅ\¼™(’ìbM7{š7+2¨l:PÓ+Ù@á©„HbQÍ/‘šwÁ ˜—Êö`ÿ6%0Ê<\'C—Šà¸œs1ŠUA«~Y‰S!m(Y– êÀsué©Âòää¯Ðwyû!›€š ümNÙj ÝøÝ[j¢‡*WÓ>§á8¾ S.7€Y´µ-ÖN©ê8¾–¹H#SmѪj6+îy—H'T(r L犕zðšïªú5è@vlRÀÊ,¯Œ1;÷¸$B[Û*ò@ílãýåY ´,t Ä2.Àéݬ꾮þÅ€@ =ôÅ3AˆK2Þq­lX@ ”m¶Ù$ü!Ö c‡m¬vmµÐ<ðD 8d6þ ôÝ÷'€33nøáˆ>‡XžÇ_€"Às_½Á =,‘Ge÷AâøƒôÜQL”=öÙ¬à7)Ò"ˆl@>† r· "–Ï`C üdäúç†÷­z‡¯ƒìͳe+ 5ã!À > G8Ñ„#thD N¸a‘Äc°ˆ´Ê+cí|sÎû@NÇ"” ÝH4h Ór>tD-8ƒE>'0èQÀÈ’Õª™€ RÀ%¨'4D¤¢pØƼ—‚db€Òw3›@F cÞÈÞ1€òB> ` HBûëß {' Â"þ žB7:vd²yÚà'*ÜaàF z€8lO‡°A –ð„ŽB<\èú6:³Mƒ µ›²E¯°­®u~ó$Ä‚‹Ä!Že« fƒ¤` b…FHÀ·0ÚñˆL¤áh!–Ù²óAÿ6€ Ààwp¨á t®†T¤(í¸Ô1q%°Á|Àƒ Pr–üŸ0…D”Ä“eË(ú&‡PŽ2q )p@¤@˜%÷ËXö AL° • àkæÁÄ怉ֱ®xÀC(˜£Žy cB€"³@Ðb  Í)˜`)yÿŽ¾ÃÀj½í/ðÊY\Ô°” •%èB:Ï%´à L0 SâÅ+)4ä6R@ °pB „” A‚– M1D” âK‰eÔd&€™Ç^ Î<R‘¶À¡-*œ@K˜€1EI·°‰£^AM6ê‚\¹*ä«œáL`‚žð—ÚÓ¨zØœJ2u©f%«guÎl.„€‚¨áäàÅWMÀ=Ø’%ÁjÕ~X%“AŽ©²Ér bZœa“€I^[õ_ih£ 3Ï… ˨õRßyÅ?/Ó¡sIå/}_ »¬9l°8éVdoæ ÈNµCúhNþÔ%%Ùøâ‘èÐc7Z[s­Š'M3ò!x@!X.r˳Í@Êpÿ¢ Màº×Í@8$ƒCh…Üúi‡±Æ&Ý¢A°Ë^l·»çð‡s€ À¦8šONÐÞþr@+8da%ïà7@úʼn/úÛßíŽ`Àš"Èw(ðÔç$Ø&¥°.ƒÛ+ö f‚žšô£¿d ƒ*ÚKƒ#¤W~Žsþž‚8{; ¹/lc!ç‚ÀDð€ +ØýUE)a ìn 'P ² †$ c:/MðÁþš¢” v9à$Œ€*ø¬þÐÐ2MôäöÞ‚ ·pò“‹æ+riˆ$°Þöjƒ½d63 tðƒ#Ð^ˆPç gà¸É=¾ #|+ÒIÇ< Ý“¹+ ‚€³Pq€z!†X]èìž:# A”#âÕ Q€V0‚Y{€È>.p­k [`Á¯sœ`#¶½í$—Dpö¤À#°™Úq‡ N°‚à:Û#h·ªý…#±@·Bl1hà&‚ª5Íè+Ø›åØ‘¾ †P\ÁÃZˆ¸¤ü^ü ç^8B¬À†#T¼âø‚Á¥°A#°à aÐ8CÚQ’oáRBîÍOd\å ƒ'Þ`“³€؈Å+p.‘5=åDOºÒ—Îô¦;ýéPI@;tcltk2/inst/gui/SciViews.ico0000755000176200001440000002043614656355210015465 0ustar liggesusers(Vh~ èæ ¨Î 00¨v( €€€€€€€€€€€€€ÀÀÀÿÿÿÿÿÿÿÿÿÿÿÿ]PÝÐ0ÝPó??_ó_0R"""/Sÿ ¢"#"# ª5?PSÿP35ÿPû0U»0ÿÿñÿàÿàßàððà€€ðÀ€ƒ?ƒÿÇÿ( €€€€€€€€€ÀÀÀÀÜÀðʦ>]|›ºÙð$$ÿHHÿllÿÿ´´ÿ>](|2›<ºFÙUð$mÿH…ÿlÿµÿ´Íÿ*>?]T|i›~º“Ùªð$¶ÿHÂÿlÎÿÚÿ´æÿ>>]]||››ººÙÙðð$ÿÿHÿÿlÿÿÿÿ´ÿÿ>*]?|T›iº~Ù“ðª$ÿ¶HÿÂlÿÎÿÚ´ÿæ>]|(›2º<ÙFðU$ÿmHÿ…lÿÿµ´ÿÍ>]|›ºÙð$ÿ$HÿHlÿlÿ´ÿ´>](|2›<ºFÙUðmÿ$…ÿHÿlµÿÍÿ´*>?]T|i›~º“Ùªð¶ÿ$ÂÿHÎÿlÚÿæÿ´>>]]||››ººÙÙððÿÿ$ÿÿHÿÿlÿÿÿÿ´>*]?|T›iº~Ù“ðªÿ¶$ÿÂHÿÎlÿÚÿæ´>]|(›2º<ÙFðUÿm$ÿ…HÿlÿµÿÍ´>]|›ºÙðÿ$$ÿHHÿllÿÿ´´>]|(›2º<ÙFðUÿ$mÿH…ÿlÿµÿ´Í>*]?|T›iº~Ù“ðªÿ$¶ÿHÂÿlÎÿÚÿ´æ>>]]||››ººÙÙððÿ$ÿÿHÿÿlÿÿÿÿ´ÿ*>?]T|i›~º“Ùªð¶$ÿÂHÿÎlÿÚÿæ´ÿ>](|2›<ºFÙUðm$ÿ…HÿlÿµÿÍ´ÿ,,,999EEERRR___lllxxx………’’’ŸŸŸ«««¸¸¸ÅÅÅÒÒÒÞÞÞëëëøøøðûÿ¤  €€€ÿÿÿÿÿÿÿÿÿÿÿÿþýýÁ0ýýÁ0ï0Á0ÿ0óÁÿÿ0Áÿ0HÁHHHíéUSèHÿÁíÿÿÿéVúWíHHHëHHHíXúX0ìôÿ0ÿÁÿÁ0ÿÿÁ21/0ÁÿÿÁ541óÁÁò742ÿÿñÿàÿàßàððà€€ðÀ€ƒÿÇÿ( @€€€€€€€€€€€€ÀÀÀÿÿÿÿÿÿÿÿÿÿÿÿUUÝÕP ÝÝU ÝýÕp ÝÝÕ70ÝÝÐU3ó0PUS?ó0_ÿõSÿó_ÿÿ÷U3_ÿÿóõ_3Uÿÿ3õS0""""""""#""" r"""""u3"ª¢ /ÿÿõóÿÿÿ3÷ ª¢ r"""#ÿÿó5R ªª """"3%Pªª5_ÿ3ÿUÿ_ó?ÿõÿU3ÿÿõÿó?ÿÿõp33_ÿÿõ»³0ÿÿõ »33Uÿõ »³UPp»0pÿÿÿÿÿÿÿÿÿßÿÿÿÿÿþÿÿüÿÿüÿÿüùÿüáÿþÁÿÿÿÿÿÿÿÿÿøÀÀÀþÿ€ÿ€ÿÿÿøÿðÿðÿðÿð‡ÿðÿÿø?ÿÿÿÿÿÿÿÿÿÿ( @ÿÿÿÿ{½{ÿÿ½{½ÿÿƒÅÅÕîî¬ÕÕZ¬¬{œ{´j´s½s‹ÅÅj´j½s½Í”ͽ޽͜Í{½½b´bÅ‹ÅŃŃŃœÍ͔͔޽Þî´ÞÞ¬R¬A¤¤Åîî¤ÕÕͽ½ssÿÞ´Þ”ÍÍîîR¬sööîæî{ÿÿ¤Õ¤½œƒƒsb´´j´´ÿÿÍæÍöæÕRÍîÍbbÅææÞ{ÞÞîîæÅæîÕÕÕÍÕÍÞÍÞjjÕ¬Õ1æ1sJs‹Aœ¬jœ¬Z¤Z‹J‹ÿÿb´¤ÕÕööbb1{1ÿRÿÅÅææZZA¬¬æÕæR¬¬‹‹9œƒ½´Õ´A¤{Z¬sb´jÅæŬ‹½æ¬æƒƒb1bRÿÿ{Å{ƒsƒÿÿJ¤sœJœJ¤¤œb´sÕÕƒÕÕ´´ƒbbbƒ‹´Õ¤Õ {{ŽÅ{ÿÿÅÅÍæj)Þ)œAœ´b´AƒA ƒƒ{”´j´ƒAs”ƒ¬½ƒ´´9œœ””¤¤ ÿ ͤÍJÅÅŤÅÿÿÍÕÕR´‹Å‹¬J¬J´´¤îÞîbÕbZZœœR¬RÍͽ½öö‹9ƒ´ææ{{”¤´¤¬¬¤¤´¤Åœ9œ‹Å¬Þîޜ͜ö1œjZ{Zö{ö¤¤bbœbœJœœ1ö1îÍîæbæ´Þ´î¤îÍÿÿZÿZ{A”ƒƒú B o xxñBú ¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾ö¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾ŒŒŒtWö¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾r£££Ÿ[W¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾££r½¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾TjB‹¾¾¾¾¾¾3¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾*Njrt¾¾¾¾¾ƒŠŠ¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾Ÿ¾©¾<\< ¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾ŒŒ¾wlc < ¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾½¾¾™³fcm¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾€KllY!m¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾?3l3¾¾¾¾¾¾y¾¾¾¾¾¾¾¾¾¾¾F'!™l’m<¾¾ˆz~“¾¾¾¾¾¾¾¾¾5•¯ S‚S;®S¾˜Jˆ“¾¾¾¾¾-‚‚Li•_•-‚;Ls¾¡767.1¾¾¾¾¾s5&' ¼¾77/¾¾¾¾¾•S‚³ `iH]¾7˜¾¾¾¾¾¾¾¾¾••x¯L a®LLH¾¾7¾¾¾¾¾¾¾¾¾¾¾¾¾ m?  ¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾Š™3 ¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾\wF m€¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾v´¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾00;¾e´¼?¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾|p|§$¾'m¾¾l?l¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾QpA¾ƒ¾¾¾¾© ¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾{¦‰0¾¾¾¾¾¾¾lM?¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾p¦¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾¾ÿÿÿÿÿÿÿÿÿßÿÿÿÿÿþÿÿüÿÿüÿÿüóÿüáÿþÿÿÿÿÿÿÿÿÿøÀÀÀüÿ€ÿ€ÿÿÿüÿøÿðÿðÿðƒÿø?ÿÿüÿÿÿÿÿÿÿÿÿÿ(0` €€€€€€€€€ÀÀÀÀÜÀðʦ>]|›ºÙð$$ÿHHÿllÿÿ´´ÿ>](|2›<ºFÙUð$mÿH…ÿlÿµÿ´Íÿ*>?]T|i›~º“Ùªð$¶ÿHÂÿlÎÿÚÿ´æÿ>>]]||››ººÙÙðð$ÿÿHÿÿlÿÿÿÿ´ÿÿ>*]?|T›iº~Ù“ðª$ÿ¶HÿÂlÿÎÿÚ´ÿæ>]|(›2º<ÙFðU$ÿmHÿ…lÿÿµ´ÿÍ>]|›ºÙð$ÿ$HÿHlÿlÿ´ÿ´>](|2›<ºFÙUðmÿ$…ÿHÿlµÿÍÿ´*>?]T|i›~º“Ùªð¶ÿ$ÂÿHÎÿlÚÿæÿ´>>]]||››ººÙÙððÿÿ$ÿÿHÿÿlÿÿÿÿ´>*]?|T›iº~Ù“ðªÿ¶$ÿÂHÿÎlÿÚÿæ´>]|(›2º<ÙFðUÿm$ÿ…HÿlÿµÿÍ´>]|›ºÙðÿ$$ÿHHÿllÿÿ´´>]|(›2º<ÙFðUÿ$mÿH…ÿlÿµÿ´Í>*]?|T›iº~Ù“ðªÿ$¶ÿHÂÿlÎÿÚÿ´æ>>]]||››ººÙÙððÿ$ÿÿHÿÿlÿÿÿÿ´ÿ*>?]T|i›~º“Ùªð¶$ÿÂHÿÎlÿÚÿæ´ÿ>](|2›<ºFÙUðm$ÿ…HÿlÿµÿÍ´ÿ,,,999EEERRR___lllxxx………’’’ŸŸŸ«««¸¸¸ÅÅÅÒÒÒÞÞÞëëëøøøðûÿ¤  €€€ÿÿÿÿÿÿÿÿÿÿÿÿââââââ¿¿¿¾²¾âÁÁÁÀ¿²²âÂÂÂÂÂÁ¿²âÂÄÄÄÄÃÂÁ¿¾²âÄýýýýÄÃÂÁ¿²âýýýÄýýÄ¿¾âýýýÆÅýýÃÂÀ¾óðâýýÆÇýýÂÀ¾100ïâýýýýýýÂâÀñô0îÿÿï1âýýýýýÃâ¿ÁÁñô1ôÿÿÿ1îÂâýýýÄâÀïïîÁñô1ôÿÿÿÿ11ÀÂââââ»ÿÿñîîÁéôÿÿÿÿÿ1ñÁÿÿÿÿÿÿÿÿðîÌÁôÿÿÿÿ1ôÁÿÿÿÿÿÿÿÿôèíîîÿÿÿÿîïïÁÿÿÿÿÿÿÿÿïðïîÁÿÿô1ðââââòÁÿÿÿÿÿÿÿððÿòïîîôÿï1ôâRRRRââÿÿÿÿÿÿñïÿÿÿïîðóîïÿâTTTSSRâïòøì\ì=íîî\íìêéí1ôíâUVVVVUSâìëééZHæèèéé<çéééééçæ;; "Notebook:click $w %x %y" bind $w "Notebook:scheduleExpand $w" eval Notebook:config $w $args } # # Change configuration options for the notebook widget # proc Notebook:config {w args} { global Notebook foreach {tag value} $args { switch -- $tag { -width { set Notebook($w,width) $value } -height { set Notebook($w,height) $value } -pages { set Notebook($w,pages) $value } -pad { set Notebook($w,pad) $value } -bg { set Notebook($w,bg) $value } -fg { set Notebook($w,fg,on) $value } -disabledforeground { set Notebook($w,fg,off) $value } } } # # After getting new configuration values, reconstruct the widget # $w delete all set Notebook($w,x1) $Notebook($w,pad) set Notebook($w,x2) [expr $Notebook($w,x1)+2] set Notebook($w,x3) [expr $Notebook($w,x2)+$Notebook($w,width)] set Notebook($w,x4) [expr $Notebook($w,x3)+2] set Notebook($w,y1) [expr $Notebook($w,pad)+2] set Notebook($w,y2) [expr $Notebook($w,y1)+2] # PhG: change pad height from 30 to 20 in the following line set Notebook($w,y5) [expr $Notebook($w,y1)+20] set Notebook($w,y6) [expr $Notebook($w,y5)+2] # PhG: added 10 to the following computation to compensate smaller pad height set Notebook($w,y3) [expr $Notebook($w,y6)+$Notebook($w,height)+10] set Notebook($w,y4) [expr $Notebook($w,y3)+2] set x $Notebook($w,x1) set cnt 0 set y7 [expr $Notebook($w,y1)+5] ;# PhG: text offset changed from 10 to 5 foreach p $Notebook($w,pages) { set Notebook($w,p$cnt,x5) $x set id [$w create text 0 0 -text $p -anchor nw -tags "p$cnt t$cnt"] set bbox [$w bbox $id] set width [lindex $bbox 2] $w move $id [expr $x+10] $y7 $w create line \ $x $Notebook($w,y5)\ $x $Notebook($w,y2) \ [expr $x+2] $Notebook($w,y1) \ [expr $x+$width+16] $Notebook($w,y1) \ -width 1 -fill white -tags p$cnt ;# PhG: width changed from 2 to 1 $w create line \ [expr $x+$width+16] $Notebook($w,y1) \ [expr $x+$width+18] $Notebook($w,y2) \ [expr $x+$width+18] $Notebook($w,y5) \ -width 1 -fill gray40 -tags p$cnt # PhG: above, width change from 2 to 1 and fill from black to gray40 set x [expr $x+$width+20] set Notebook($w,p$cnt,x6) [expr $x-2] if {![winfo exists $w.$cnt]} { frame $w.$cnt -bd 0 } $w.$cnt config -bg $Notebook($w,bg) place $w.$cnt -x $Notebook($w,x2) -y $Notebook($w,y6) \ -width $Notebook($w,width) -height $Notebook($w,height) incr cnt } $w create line \ $Notebook($w,x1) [expr $Notebook($w,y5)-2] \ $Notebook($w,x1) $Notebook($w,y3) \ -width 1 -fill white ;# PhG: width changed from 2 to 1 $w create line \ $Notebook($w,x1) $Notebook($w,y3) \ $Notebook($w,x2) $Notebook($w,y4) \ $Notebook($w,x3) $Notebook($w,y4) \ $Notebook($w,x4) $Notebook($w,y3) \ $Notebook($w,x4) $Notebook($w,y6) \ $Notebook($w,x3) $Notebook($w,y5) \ -width 1 -fill gray40 # PhG: above, width change from 2 to 1 and fill from black to gray40 $w config -width [expr $Notebook($w,x4)+$Notebook($w,pad)] \ -height [expr $Notebook($w,y4)+$Notebook($w,pad)] \ -bg $Notebook($w,bg) set top $Notebook($w,top) set Notebook($w,top) -1 Notebook:raise.page $w $top } # # This routine is called whenever the mouse-button is pressed over # the notebook. It determines if any page should be raised and raises # that page. # proc Notebook:click {w x y} { global Notebook if {$y<$Notebook($w,y1) || $y>$Notebook($w,y6)} return set N [llength $Notebook($w,pages)] for {set i 0} {$i<$N} {incr i} { if {$x>=$Notebook($w,p$i,x5) && $x<=$Notebook($w,p$i,x6)} { Notebook:raise.page $w $i break } } } # # For internal use only. This procedure raised the n-th page of # the notebook # proc Notebook:raise.page {w n} { global Notebook if {$n<0 || $n>=[llength $Notebook($w,pages)]} return set top $Notebook($w,top) if {$top>=0 && $top<[llength $Notebook($w,pages)]} { $w move p$top 0 2 } $w move p$n 0 -2 $w delete topline if {$n>0} { $w create line \ $Notebook($w,x1) $Notebook($w,y6) \ $Notebook($w,x2) $Notebook($w,y5) \ $Notebook($w,p$n,x5) $Notebook($w,y5) \ $Notebook($w,p$n,x5) [expr $Notebook($w,y5)-2] \ -width 1 -fill white -tags topline ;# PhG: width changed from 2 to 1 } $w create line \ $Notebook($w,p$n,x6) [expr $Notebook($w,y5)-2] \ $Notebook($w,p$n,x6) $Notebook($w,y5) \ -width 1 -fill white -tags topline ;# PhG: width changed from 2 to 1 $w create line \ $Notebook($w,p$n,x6) $Notebook($w,y5) \ $Notebook($w,x3) $Notebook($w,y5) \ -width 1 -fill white -tags topline ;# PhG: width changed from 2 to 1 set Notebook($w,top) $n raise $w.$n } # # Change the page-specific configuration options for the notebook # proc Notebook:pageconfig {w name args} { global Notebook set i [lsearch $Notebook($w,pages) $name] if {$i<0} return foreach {tag value} $args { switch -- $tag { -state { if {"$value"=="disabled"} { $w itemconfig t$i -fg $Notebook($w,fg,off) } else { $w itemconfig t$i -fg $Notebook($w,fg,on) } } -onexit { set Notebook($w,p$i,onexit) $value } } } } # # This procedure raises a notebook page given its name. But first # we check the "onexit" procedure for the current page (if any) and # if it returns false, we don't allow the raise to proceed. # proc Notebook:raise {w name} { global Notebook set i [lsearch $Notebook($w,pages) $name] if {$i<0} return if {[info exists Notebook($w,p$i,onexit)]} { set onexit $Notebook($w,p$i,onexit) if {"$onexit"!="" && [eval uplevel #0 $onexit]!=0} { Notebook:raise.page $w $i } } else { Notebook:raise.page $w $i } } # # Return the frame associated with a given page of the notebook. # proc Notebook:frame {w name} { global Notebook set i [lsearch $Notebook($w,pages) $name] if {$i>=0} { return $w.$i } else { return {} } } # PhG: added a function to get the frame associated with the current tab. proc Notebook:current.frame {w} { global Notebook set top $Notebook($w,top) if {$top>=0 && $top<[llength $Notebook($w,pages)]} { return $w.$top } else { return {} } } # PhG: added a function to get the name of the current tab. proc Notebook:current {w} { global Notebook set top $Notebook($w,top) if {$top>=0 && $top<[llength $Notebook($w,pages)]} { return [lindex $Notebook($w,pages) $top] } else { return {} } } # # Try to resize the notebook to the next time we become idle. # proc Notebook:scheduleExpand w { global Notebook if {[info exists Notebook($w,expand)]} return set Notebook($w,expand) 1 after idle "Notebook:expand $w" } # # Resize the notebook to fit inside its containing widget. # proc Notebook:expand w { global Notebook set wi [expr [winfo width $w]-($Notebook($w,pad)*2+4)] set hi [expr [winfo height $w]-($Notebook($w,pad)*2+36)] Notebook:config $w -width $wi -height $hi catch {unset Notebook($w,expand)} } tcltk2/inst/tklibs/notebook1.3/example.tcl0000755000176200001440000000533714656355210020145 0ustar liggesusers#!/usr/bin/wish # # Adapted from tree.tcl example file by Ph. Grosjean, 2005 # # I am D. Richard Hipp, the author of this code. I hereby # disavow all claims to copyright on this program and release # it into the public domain. # # D. Richard Hipp # January 31, 2001 # # As an historical record, the original copyright notice is # reproduced below: # # Copyright (C) 1997,1998 D. Richard Hipp # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Library General Public License for more details. # # You should have received a copy of the GNU Library General Public # License along with this library; if not, write to the # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. # # Author contact information: # drh@acm.org # http://www.hwaci.com/drh/ # # $Revision: 1.3 $ ################# # # The following code implements an example of using the # notebook widget. # source "./notebook.tcl" Notebook:create .n -pages {One Two Three Four Five} -pad 3 pack .n -fill both -expand 1 set w [Notebook:frame .n One] label $w.l -text "Hello.\nThis is page one" pack $w.l -side top -padx 10 -pady 50 set w [Notebook:frame .n Two] text $w.t -font fixed -yscrollcommand "$w.sb set" -width 40 $w.t insert end "This is a text widget. Type in it, if you want\n" pack $w.t -side left -fill both -expand 1 scrollbar $w.sb -orient vertical -command "$w.t yview" pack $w.sb -side left -fill y set w [Notebook:frame .n Three] set p3 red frame $w.f pack $w.f -padx 30 -pady 30 foreach c {red orange yellow green blue violet} { radiobutton $w.f.$c -fg $c -text $c -variable p3 -value $c -anchor w pack $w.f.$c -side top -fill x } set w [Notebook:frame .n Four] frame $w.f pack $w.f -padx 30 -pady 30 button $w.f.b -text {Goto} -command [format { set i [%s cursel] if {[string length $i]>0} { Notebook:raise .n [%s get $i] } } $w.f.lb $w.f.lb] pack $w.f.b -side bottom -expand 1 -pady 5 listbox $w.f.lb -yscrollcommand "$w.f.sb set" scrollbar $w.f.sb -orient vertical -command "$w.f.lb yview" pack $w.f.lb -side left -expand 1 -fill both pack $w.f.sb -side left -fill y $w.f.lb insert end One Two Three Four Five set w [Notebook:frame .n Five] button $w.b -text Exit -command exit pack $w.b -side top -expand 1 tcltk2/inst/tklibs/ttktheme_radiance/0000755000176200001440000000000014656355210017404 5ustar liggesuserstcltk2/inst/tklibs/ttktheme_radiance/radiance/0000755000176200001440000000000015017102465021144 5ustar liggesuserstcltk2/inst/tklibs/ttktheme_radiance/radiance/button-p.gif0000644000176200001440000000174414656355210023417 0ustar liggesusersGIF89aÆk²y^³z_²zeµ{`³{f¶|a´|g·}b¶}h·~h¸iº€e¹€jºk¼ƒm½„n¾…oÀ…jÀ†pÆ…lˆrÅŠoÂŽvÃwÄxÆ“zÇ”{Í“|îŒeÈ•|ïfëfðŽgË—~ìgòh̘å’qí‘hì‘nóiæ“rï’iî’oð“jã–sï“pñ”kð”qã—zé–uò•lñ•rä˜{å™|ò—rõ—nô˜sç›~ïšsõ™tñ›tÔ¡Žöšuòœu÷›vóv×£ôžwóž}õŸxôŸ~ö yõ Ú§“ö¡€Û¨”ù¢{ø¢ù¤‚ô¦‚ú¥ƒö§ƒà¬˜Û®˜÷¨„ð»§ì¾¨í¿©ïÁ«ð¬òíùïóǶöȱôÈ·õɸóÏÃôÐÄïÒÄõÙÊóãÞôäßöæáõíåõïîùôòÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!þCreated with GIMP!ù ,þ€jjhbYWVˆ‰Š‹‰Zbh‚jeXC—˜™š˜>WfƒW-4=¨©=<ª­42^icC4BGGHF½½ºÀº¾GFGJd[)BKONÐÏÑNOÕÕÔÖO:`V4DNRãOQåãQRQëéãRUUO\V;DÎÙÔÓÙ×åéè À•Ú’ƒ&t⌚”€õ.I’ä Å‹/9ø b@Œ,1‚„/_({ñ¢ØÄIz߀1B¤&!7kâ´©“äÁyVÐàSˆ A„´iÓ¤EˆP<sh"Kƒá±¯`¿Ê$‚$ P0††åA£-þmã]5óÐ/äê¥1£ïÞ¶@j& §À…^3`¼X̘qÚ¶D…( ÌÂ-Å.³xÁ¢³çqI¦Ç€ÅŒ¶.<«0¡¢µk×, ƒ€Þ]¨`BÅÀg;- Ho^Üšµ "¢‹nBDë¼_k[i âEjÓExO¾üô²i4 Ç=ö àãÅCÿðÁ4•–—˜–> 9"ƒ):£¤¥¦§)'5B2¯°±²³¯1, ?º»¼½¾» ÅÆÇÈÉƆ@ÏÐÑÒÓÐ@†ÙÚÛÜÝÚ†ãäåæçäá<ìíîïðíê=ö÷øùú÷† H0à$*\È°¡Âƒ8œH¢ 3jÜÈ1£ CˆI²¤É‘ Å(Á²¥Ë—0[Æ0¡…Í›8sê¼ ÁP@ƒ J4hC2(]Ê´©Ó¥2 ExAµªÕ«X«F04ƒ‚ׯ`Êý:ÃhÓª]Ë6­† D FܘK·®Ý»t{4¨A €¿€   BF!LÀÀÁ¸±ãÇXa"ˆ ÜD‰<:qK‘éDŒLˆ;tcltk2/inst/tklibs/ttktheme_radiance/radiance/scale-hn.gif0000644000176200001440000000055614656355210023341 0ustar liggesusersGIF87a ¥ÑÉÃÐÉÂÎÇÀçãßôñïãßÛüûúëéæúùøż³Á¸¯ÞØÒëæâåàÜñîëíêçùøöéæã÷öôöôóèãÞÓÍÆâÝØÐÉÃèåáõóñļ³À¸¯àÚÕîê掳À·®ÏÇÀËüÕÏÉãßÚèåâÿÿÿýýýØÒËÔÎÇíêæëèäöôòþþýîìêýüü, “@–H±ùȤҨP \ ÀÈÓ2Y¯Ø¬¶å)T—Õ “xÎè´:ýð`ćx¬9 îø¼þ~мÅ)st*†!%ˆŠ‰‡*~ƒ‚ƒt–‰˜˜“Ÿt$‰¤%¦$ž Ÿ‰±%³«¬­ ‰¼‰·¸¹ÄÄÀÁ¹ ÌÈɹ  Ïй'Õ“A;tcltk2/inst/tklibs/ttktheme_radiance/radiance/arrowright-p.gif0000644000176200001440000000054314656355210024270 0ustar liggesusersGIF87a¥ÜÕÎÙÓËØÑÊ×ÑÉåáÚáÛÖíéåÝ×ÒÎÉÃnmkjigÚÒËÙÒÊ×ÐÈâÜÖÜÖÐêæá´±¬óðízxvòðïþþþüüüâÛÕÝ×ÐÙÓÌŽ‹‰îëç{yv•’“ÝÖÏåàÚáÜÖØÒÍçäßóðîûúùãÝ×usqrqnãÜÖÞØÑçäàòðîÍÈÃýüü”‘Ž,ˆ@‡ã#hÁç" V†TJb©2¡ÀJ ¿&HéŒßÖW¡¯0Y›,ƒÆf­8½_F{_ B‚z|'("Œ„B†ˆŠ”ƒ|~€‹ &_tvx,ik, *%¤vb.ÀÀ, !!eyG¡±ÇA;tcltk2/inst/tklibs/ttktheme_radiance/radiance/arrowleft-d.gif0000644000176200001440000000107114656355210024066 0ustar liggesusersGIF87aÆÜÕÎÚÓÌÙÓËÉÁ¸×ÑÉƽµÕÍÇâÝ×íéåìéäëçãéåáèåàþýüȾ¶×ÐÈƼ´ÕÌÆÓÌÄú±âÜÖîêåíèäëæâéæàäàÛñîëôòñþþþÁ·®ßÙÒÙÓÌâÝØñíêîëçëçäéåâõóñüûûÚÔÌÊÀ¹ÉÀ¸ÕÎÇíêåíèåìèäéæáñîìǽµÄ»²Â¹°Ý×ÑìçãÜÕÐéåàÐÈÀßØÒÜÖÏéäßÖÎÉåàÛòîëîêçìèåéæâôòð,ž€-#†‡4‚9 ’’=$89 &/-ŸŸ?>3A  Ÿ . žª52AŸ+ª7%Ÿ"†¼Ÿ<);ÁÃÅŸ:10Ì-Ä» 6(Õ×ÆŸ,*Þ!ªŸ Â-¹ é- · '8>?颤(È1H®p1€‚ À:dˆÀ -;tcltk2/inst/tklibs/ttktheme_radiance/radiance/arrowdown-d.gif0000644000176200001440000000055114656355210024105 0ustar liggesusersGIF87a¥ÜÕÎÚÓÌÙÓË×ÑÉÖÍÈâÝ×ßÙÔíéåìéäëçãéåáþýü×ÐÈż³ÔÌÅâÜÖîêåíèäëæâéæàñîëøöõôòñþþþÁ·®ßÙÒÙÓÌÉÁ¹ÕÏÈÕÍÈñíêîëçíéæëçäéåâçãàüûûÚÔÌÉÀ¸íêåìèäéæáñîìƽ´ÒËù°Ý×ÑìçãçáÞßØÒÜÖÏÈÀ¸ÖÎÉåàÛòîëîêçìèåéæâöôòôòðóðï,Ž@Tè!`Íã%”e,‹‹TjÅd‰G†¤: ¾ßîæ*v°ú‹Hi ïZ}0.óõLj¯µ0€€-8({w_+4+#i†x_,3:_‘`&+&`{j0 <7`u j il%178kbd 2.9ÄÄ'). ( oGF%¾(A;tcltk2/inst/tklibs/ttktheme_radiance/radiance/sbthumb-vp.gif0000644000176200001440000000051214656355210023726 0ustar liggesusersGIF87a ¥ÜÕÎÛÕÍ×ÑÉãÝØàÛÕöóñôñïø÷ö×ÐÈÞØÒïìéôòñþþþîëçöõòõóñþýýýýüîêæõòðõôóçãÞù÷ööõóýýýàÚÓßØÒÛÔÎçâÝëèäøöôöôòóòï, oÀσ Ž‚g!Ld:’†ÔC$†¨ðé~B%Ð1xÏ–Ë!áž½cã}fçô®Ïïûtyzwƒ‚ƒˆ~…‰Œ‹†yo`b  ¨BFH®A;tcltk2/inst/tklibs/ttktheme_radiance/radiance/scale-hd.gif0000644000176200001440000000055514656355210023326 0ustar liggesusersGIF87a ¥ÖÏÈãÝØíéåìéäëçãüûúÔÌÅàÚÔßØÓÞØÒêæáéäàèäßðîêÛÕÎÖÏÉäßÚñíêîëçõóñóñïǾ¶äÞÙâÜ×ÝØÒñîìÕÍÆÛÕÏéåàèãßçãÞðíêçâÝæâÜåàÛïìèíêæëèäêæãöôòðîì, ’À Bc(ȤQ£I 6 Ó£D©Z¯Øléa:80§éÁù˜Ïè4šó …1°øÁÙïø¼Ñ–G&rb…‡‰ˆ†}r€‚ •ˆ—— n’Ÿs!ˆ¤¦! Ÿc"ˆ°²"«¬­ˆ »ˆ¶·¸ ÃÿÀ¸ËÇȸ ÎϸÔ’A;tcltk2/inst/tklibs/ttktheme_radiance/radiance/arrowright-a.gif0000644000176200001440000000054214656355210024250 0ustar liggesusersGIF87a¥×ÑÉâÝןŸŸúùøø÷ööõôôóòâáà×ÐÈßÚÓ  ŸžžéäàõòïïìéÅÅÃúø÷ööóþþþ‚‚xxwttsÛÕÎîëçìéåþýýûûúàÚÕîêæéæáõò𘘘ùø÷îîì‚‚‚ãâáÛÕÏéåàëéåù÷ööõóýýý{{zàÚÓoonÜÖÏíêæ||z,‡À¨dAã$L ‰Tê1Ã@J3èz!(Ǧc)p»o7‚!2êÊC r5ë%0x/Fy^, "#]€xz *!Š‚]„†ˆ’z|~‰ ^rtv&^ijl- (j`b ¾¾.+¢ nGF-¢A;tcltk2/inst/tklibs/ttktheme_radiance/radiance/toolbutton-a.gif0000644000176200001440000000070514656355210024272 0ustar liggesusersGIF87a¥ÒËÄìçäÛÕÐòïíîëéúùøø÷ööõôÞØÒåàÜäàÛñîëïìéíêç÷öôôòñþþþüüüèãÞÖÏÉäßÚÞÙÔ÷õóõóñþýýýýüüûûûûúÑÊÃîêæÚÔÏõòðóðîûúùùø÷õôóêåáÚÓÎèãßäßÛîëèø÷õöõóÿÿÿýýýÖÐÉàÚÖíêæÝØÓöôòõòñôòðýüüûúú,êÀØåÔâÈ$`B™ K•dE­Z­ƒ«4„A¾à°X S´F¬´zÍf&VfN¯Ûí,éûÿ€€F†‡ˆ‰‰F,‘’’,5—˜™šš•! ¡¢££F4©ª«¬¬4§­±±¯·¸¹ººF!*ÀÁÂÃÃ!FÉÊËÌÌF" ÒÓÔÕÕ"F) ÛÜÝÞÞ)F äåæççFíîïðð2÷øùúú2-$ H &:˜À°¡Ã‡LtàA  XÛbÀ .Q'‰É#Kˆ ;tcltk2/inst/tklibs/ttktheme_radiance/radiance/tree-n.gif0000644000176200001440000000055214656355210023035 0ustar liggesusersGIF87a¥ÜÕÎÛÕÍ×ÑÉáÛÖöóñôñïø÷ö×ÐÈáÜÕÞØÒôðîôòñþþþîëçõóñþýýîêæëèãõòðõôóáÛÕßÙÓçãÞôñîù÷ööõóýýýßØÒÛÔÎçâÝïìèíêæëèäöôòóòï,À£8Ȥ€Ó‘ˆÌƒA­Z­%1Dh0¡°xL&<K`b »ß"GðxÛÇŽàÀ¸ûC F}v|„…‚ˆo†ƒ‹cd‘’b”•€Š˜™‡›—•Ÿ’¡£‹ ˜y "˜"‹fh   ÃÄÅŪsIÐGªA;tcltk2/inst/tklibs/ttktheme_radiance/radiance/sep-h.gif0000644000176200001440000000005014656355210022650 0ustar liggesusersGIF87a€ûúùãÞÙ,Œ™Àíÿ ;tcltk2/inst/tklibs/ttktheme_radiance/radiance/arrowright-n.gif0000644000176200001440000000054214656355210024265 0ustar liggesusersGIF87a¥ÜÕÎÛÕÍ×ÑÉáÛÖöóñôñï‚ø÷ö×ÐÈáÜÕÞØÒôðîôòñðîíþþþzzynnmžœœ›š——•îëçõóñþýýwwußÝÛîêæëèãõòðõôóàÞÛáÛÕßÙÓçãÞôñîù÷ööõóýýýzyyssrßØÒÛÔÎçâÝïìèíêæëèäÂÁ¿öôòóòïêèæ,‡ÀWE@‚”Š#T$H‡T*j}ÃDiôêz …(è¼oÖJ ,ê“K]a 5äix)Fy^]€xz&1/Š‚]„†ˆ’z|~‰ ^rtv-0hj/0*+«`b! -¾¾, (¢!nGF!¢A;tcltk2/inst/tklibs/ttktheme_radiance/radiance/sizegrip.gif0000644000176200001440000000011614656355210023473 0ustar liggesusersGIF89a¡àÚÔþþþÿ!ù,”©Ëí#R„Á¥/Ü‹1š0r‹g}aRn›‚Æ_;tcltk2/inst/tklibs/ttktheme_radiance/radiance/arrowup-d.gif0000644000176200001440000000055314656355210023564 0ustar liggesusersGIF87a¥ÜÕÎÚÓÌÙÓËÉÁ¸×ÑÉÕÍÇâÝ×íéåìéäëçãéåáóñîþýü×ÐÈǾµÅ¼³ÕÌÆÓÌÄú±âÜÖîêåíèäëæâéæàñîëôòñþþþÁ·®ßÙÒÙÓÌñíêîëçëçäéåâõóñüûûÚÔÌÉÀ¸ÕÎÇíêåíèåìèäéæáñîìƽ´Ä»²Â¹°Ý×ÑìçãÛÕÏÐÈÀßØÒÜÖÏéäßÖÎÉåàÛòîëâÜØîêçìèåéæâôòð,Àh"h„Î&¤q2 TŠ Íh‰ g´:¤¾ßÊN÷2z°ú‹Pu /¸¶>õ­¥PŒy_,%(`x`2%&ˆ€_16,9_‰y7.  }_ "ª« )v kj$3:;kbd 4/<ÆÆ'*/ ) oGF$À)A;tcltk2/inst/tklibs/ttktheme_radiance/radiance/progress-h.gif0000644000176200001440000000134714656355210023737 0ustar liggesusersGIF87a(ÆÀsSó}Mݼ®íÞØìÞ×ÙŠh÷ƒTõR¿uUæh6õóðÈh@û™r÷…Wír@ö…Vøeæ|Pðß×ïßÖëyKäzNïvE÷‡ZÓvQõ…Xç¾­¿kG÷‰]å¾®ó~OÍ[-¼Y0üšrò‡[ô‚Sém;èm:ÕnEæi8ÑjAÎh>ö†XìsAÒuOØtKëq@罬߼®ÑlDò{Jå{Q¾X.ÐuPÓ‰jˈlÁuUú•lêƒYêYôOå½­øŒ`úeçj8åh6°U0¿gBø‡YírAëp?ÔoFÄmJñxHû–lÞ½¯ìß×¼W.¿kHÙ‰hõ‚R¿tUÎ]/õòð¿fAíq@ÖpGÂZ0ÄlIÀX.å{OÎh?Ó‡hÓnGñ{JÑwRóOó}Oöóðø…WöƒUåqAôSên<èl:ùe±W2ÜwOîtCìrAÔoGå|Q¹c@ö’hò…Z÷„UÕnDöôòÈiAÜxN·eDƇmŇlྮÑlCå{Pʆj,(þ€u‚b/O(R‰Š‹ŒŠR(b‚•,&;q !žŸ ¡ž q:t•[}9>D c²³´µ¶³ >J3)uS5isÆÇÈÉÊËÆd?Z_b=|f×ØÙÚÛÜÙ#i1\<æçèéêëê*o6 "`ôõö÷øùø Ñ ›“(Sª\ɲ%”& <´)B³¦Í›8sâl .ŒJ´¨Ñ£F]PâçN›3P£JJµ*ÕknÀ@¦š¯`ÊK6l 6Xö(p¤ ·MpãÊK7n+8Ô!§‹'‚$L¸°áăœ áÀ œ•˜DÙТÌL˜w–iáäJuЃGÓ¨S«^Z žHL1G‡ ”ÚàˆBD”` ¤ä&!‚;tcltk2/inst/tklibs/ttktheme_radiance/radiance/scale-vd.gif0000644000176200001440000000055414656355210023343 0ustar liggesusersGIF87a ¥æáÛÖÏÈãÝØíéåëçãñïìüûúÔÌÅßØÓÞØÒìèãêæáéäàèäßÖÏÉäßÚñíêîëçõóñǾ¶äÞÙâÜ×ÝØÒìèäôòïÕÍÆàÙÔßÙÓÝ×ÑÛÕÏéåàèãßçãÞòïìðíêçâÝåàÛïìèíêæêæãöôò, ‘ÀP'‘ ŽÈ#Â’l3'g3ã0I‘‡KõŠ:`<[©WÔ7Ç%PÀzƈJ‘‘ùˆŽ óú@A2ëah……[h‹‹ U „†”#ŠŒ”–‘“&˜†ˆVžŒƒnp{}l]®vx²³oqs¸ikNce·X_»XZÂITÈÉQ\(Î(EWA;tcltk2/inst/tklibs/ttktheme_radiance/radiance/sbthumb-hd.gif0000644000176200001440000000051514656355210023677 0ustar liggesusersGIF87a ¥ÜÕÎÚÓÌÙÓË×ÑÉâÝ×íéåìéäëçãéåáöóñþýü×ÐÈâÜÖîêåíèäñîëôòñþþþÙÓÌîëçëçäõóñýýüüûûÞØÐÚÔÌÞØÓìèäôòïñîìáÛÕìçãáÚÔÜÖÏîêçìèåéæâôòð, rÀ …!XÈÅ@ÂøCRcB­ZPèÀÀˆFŽxL.t.Ba »Ý’dпïË`1¹û7F}o|„…Jˆcy%b Œfh! §¨©%sII¡A;tcltk2/inst/tklibs/ttktheme_radiance/radiance/comboarrow-p.gif0000644000176200001440000000057514656355210024257 0ustar liggesusersGIF87a¥ÜÕÎÙÓËØÑÊ×ÑÉåáÚáÛÖíéåÝ×ÒnmkjigÚÒËÙÒÊ×ÐÈâÜÖÜÖÐêæáóðíòðïþþþüüüâÛÕÝ×ÐÙÓÌŽ‹‰îëçÎÉÄ•’“ÝÖÏåàÚáÜÖçäßóðîûúùttqãÝ×´°¬ØÓÌ{ywzyvusqrqnãÜÖÞØÑçäàòðîýüü”‘Ž,¢ÀFƒ#`Œ€C,fJµV`訄àÆèrTBxÝxD× M }-1ê÷`}y€~„B‚„‰‡ Œ  ““Ž†B$(($ˆ™B/&&/…ƒ`'"'ªŠB)—²l%|£€‹I#„vJ-„- +!Âkce.ÚÛ-  gxHIËáA;tcltk2/inst/tklibs/ttktheme_radiance/radiance/check-dc.gif0000644000176200001440000000120514656355210023300 0ustar liggesusersGIF89aÆiÌúÍĻͿΎÎƽÏƾÏǾÐÇ¿ÐÈÀÑÈÀÑÉÀÒÉÁÒÊÁÒÊÂÓËÂÓËÃÕÎÆÖÎÈ×ÏÈ×ÐÈ×ÐÉØÐÈÙÒËÚÒËÚÓÌÚÓÍÚÔÌÚÔÎÛÔÌÛÔÍÜÕÎÝÕÏÜÖÏÝÖÏÝ×ÐàÙÔßÚÔàÚÔáÛÖáÜÖäßÚäßÛëåáêæáêæãëæãëçâëçãëçäêèäêèåëèäëèåìèäìèåìèæíèåíèæëéåìéåìéæíéäíéåíéæîêæîêçíëæîëçîëèîëéïëçïëèîìçîìèïìçïìèïìéðìéïíêðíéðíêðíëñíêðîëñîëñïíòïìòïíñðíòðíóðíóðîôñïõòðöóòöôòöôó÷ôò÷õôøöôø÷ôùøöùø÷úø÷úù÷ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!þCreated with GIMP!ù ,Í€3 …†…N`M(df‘‘egfc(" ^XYZZV¢VYXa B_TSRNP±TTW! +_]OQGICCHJP h_[C$D966?E ÈU& 4,,:ÔRÈT' 12 *RÈK=êê)AL 0²ƒE>u J@3"Y 5^´8ÈÁ‡‹@„QÆŒ#Fà€ÑbŒ†_"€€fãÆ< Õø0¡Ì&ØÉsg€ \Ä| ;tcltk2/inst/tklibs/ttktheme_radiance/radiance/sbthumb-vd.gif0000644000176200001440000000051714656355210023717 0ustar liggesusersGIF87a ¥ÜÕÎÚÓÌÙÓË×ÑÉâÝ×íéåìéäëçãéåáöóñþýü×ÐÈâÜÖîêåíèäñîëôòñþþþÙÓÌîëçëçäõóñýýüüûûÞØÐÚÔÌÞØÓìèäôòïñîìáÛÕìçãáÚÔÜÖÏîêçìèåéæâôòð, tÀ …,Žƒã a‰´Rò„ ŒÈàØx ‹† ¼ho"Y4ºé¯Â8‰§#Ǻ݋_è÷}v{|y…„…Š€‡‹Ž {{% ”_ac!%­LFHLA;tcltk2/inst/tklibs/ttktheme_radiance/radiance/scaletrough-v.gif0000644000176200001440000000035114656355210024423 0ustar liggesusersGIF87a „ØÑÊ×ÏÉÍÄ»×ÐÈÖÎÇâÜÖáÚÕïìéùøöÎÅ»âÛÕáÛÔêçãôòïïìêÎżØÑÉ×ÏÈáÛÕïíéíëçúù÷÷õôöôòóòïÎŽ, nà%^ØA9بb ñ“¥Š-@€Ì•(E¢Â£ HqfD”Åcr©jN£N(Sú¤Ž¬]ìu›õŠÀÚ*7ý]›{nq˜·×Ûw|yp~}_ C<5;3 2"!;tcltk2/inst/tklibs/ttktheme_radiance/radiance/sbthumb-vn.gif0000644000176200001440000000051214656355210023724 0ustar liggesusersGIF87a ¥ÜÕÎÛÕÍ×ÑÉãÝØàÛÕöóñôñïø÷ö×ÐÈÞØÒïìéôòñþþþîëçöõòõóñþýýýýüîêæõòðõôóçãÞù÷ööõóýýýàÚÓßØÒÛÔÎçâÝëèäøöôöôòóòï, oÀσ Ž‚g!Ld:’†ÔC$†¨ðé~B%Ð1xÏ–Ë!áž½cã}fçô®Ïïûtyzwƒ‚ƒˆ~…‰Œ‹†yo`b  ¨BFH®A;tcltk2/inst/tklibs/ttktheme_radiance/radiance/progress-v.gif0000644000176200001440000000133514656355210023752 0ustar liggesusersGIF87a(ÆÀsSó}Mݼ®íÞØìÞ×ÙŠh÷ƒTõR¿uUæh6õóðÈh@û™r÷…Wír@ö…Vøeæ|Pðß×ïßÖëyKäzNïvE÷‡ZÓvQõ…Xç¾­¿kG÷‰]å¾®Í[-ó~O¼Y0üšrò‡[ô‚Sém;èm:ÕnEæi8ÑjAÎh>ö†XìsAÒuOØtKëq@罬߼®ÑlDò{Jå{Q¾X.ÐuPÓ‰jˈlÁuUú•lêƒYêYôOå½­øŒ`úeçj8åh6°U0¿gBø‡YírAëp?ÔoFÄmJñxHû–lÞ½¯ìß×¼W.¿kHÙ‰hõ‚R¿tUÎ]/õòð¿fAíq@ÖpGÂZ0ÄlIÀX.å{OÎh?Ó‡hÓnGñ{JÑwRóOó}Oöóðø…WöƒUåqAôSên<èl:ùe±W2ÜwOîtCìrAÔoGå|Q¹c@ö’hò…Z÷„UÕnDöôòÈiAÜxN·eDƇmŇlྮÑlCå{Pʆj,(þ€u‚S=\ WY4M T~0 ‚‘5|"PwH‘[`^Ilm.mlGpLub,}if<2ªlEFg%U]Q /&9sº¼«¿gh@O;>Ë»½ÏÑ$-z(qDÙÌÜÀÑ'exR åÛÎè@Amj!cð;ó EBðéÓƯóí;í @ å5D‘ ÃhZ”ˆñ¡Fs&²ßD$ã™ì82âJ‘K̘² ?”.gâÜø’fΛ-yê *hL•CÚÛl>Ýl@Þm?ìuEívEïvFîwGïwFïwGïxGïxHðxGå{OñyHæ|PðzJñzJñzKòzJÈ„hÉ„hï|NÏ„fó|Lð}Nð~Oñ~Oφhó~Oô~OòSõRõS؈g؈hö„WÞŠgë‡_ÞŠhÍŽtö…WÎuÏwÏ‘v÷ˆ[øˆ[ø‰[ôŠ`÷Š]øŠ]õ‹`Þ‘rù‹_Ý’rÝ’søŒaß’súŒ_øb÷ŽcøŽcúdùeó’lò“lö“l÷“kõ—põ—qø—qï›yó›xðœyúšr÷œw÷x÷ ~ù |ù }ö¡÷¡}÷¢÷¢ô¤ƒô¤„ú©ˆü©‡Ø¼±Ø½²ÜÀ´ÜÁµæǹæȺéɼéʼßÙ×àÙÖâÝÛãÞÛäßÜåàÝíéåíéæîëéðíëòðîóðîõòðöôòÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!þCreated with GIMP!ù ÿ,Ó"”H† 2ÑCè@AT*A#G› ž:4H ‡2Z T©%K˜ QÝyÐ% 5q⤹’ÄK<=T ™òƒàXQ‚ÂG'<Î\ÀÀ3;–H0Ð$‡›M pƒƒ‰?f¬ÁÚt@›D 0 Ñ …¬¾¸ˆá@†‡:ÄL`,:ܨƒÀ‰\ÆŒÙbã„ vþ ¢ˆ!Fá B|†Ðð!EŠÙS‘¡>s^, @` :~Z;tcltk2/inst/tklibs/ttktheme_radiance/radiance/check-nu.gif0000644000176200001440000000060514656355210023337 0ustar liggesusersGIF89a¥5¨œ‘°¥›Ãº°ÈÀ·ÌĽÑÈÀÒËÅÕÌÅÕÍÅÚÔÎÛÕÏÞ×ÓÞØÒâÝ×ãÝØèçåèçæéééêêêëêéðëèìììðìéðìêíííðîêðîëñîëïïïòïíðððòðìóðîñññòñðôñïòòòôòðôóò÷óòöôòøôóõõõöõôøõôööö÷÷÷øøøùùùúúúûûûüüüýýýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!þCreated with GIMP!ù ?,@ !(‹¥ƒJ’ˆt*Ô`‚Qµ¾`f2¸ •–kÍ^·*³óªÛïAv~ï¿òg0„…†g1Žg!2–—˜! g$˜Ÿ2$#g*23¨©¨2*%Z".34´µ3."(( &.``.& +(' ÌÍÌ),(A;tcltk2/inst/tklibs/ttktheme_radiance/radiance/scale-vn.gif0000644000176200001440000000055714656355210023360 0ustar liggesusersGIF87a ¥ÑÉÃÎÇÀçãßôñïüûúëéæúùøÁ¸¯ÞØÒëæâåàÜñîëíêçùøöéæã÷öôöôóèãÞâÝØÐÉÃèåáõóñļ³àÚÕÐÈÂîêæÕÐÊŽ³À·®ÏÇÀËü×ÑËãßÚÒÍÆèåâÿÿÿÔÎÇíêæëèäöôòþþýîìêýüü, ”@TPªœŽÈ£f’l gó°¡H‘œTõzâ «ÔK(„Ç(‚Átn’ G›†?Dón½ñ€æo| moˆˆgo#ŽŽa}  ‡‰˜#˜š”ƒ—’œ‰‹V¢†{}bzj|x¶·pr»¼l¿·fÂz`Å]ZÈ'TËÌQ\'$!Ñ'*EWA;tcltk2/inst/tklibs/ttktheme_radiance/radiance/toolbutton-d.gif0000644000176200001440000000126114656355210024273 0ustar liggesusersGIF87aÆåßÚäßÙáÛÖßÙÔíéåìçäëçãèãàáÚÕàÚÔÞØÒìèãëæâêæáÚÔÎéäàèäßçâÞïìéîìèäÝ×ÚÓÍèãÞçãÝçáÝæáÜåáÛåßÛäßÚïíèïëèßÙÕîëçëçäõóñæàÛåàÚáÚÖîìæîêæíêåíèåìèäëæãêæâéäáèäàõòðæßÚáÛÕÞ×ÒíéäìçãêåáéåàèãßçãÞæáÝðíêÞØÑéäßèâÞçâÝæâÜæàÜãÞÙðìéàÚÖìèåöôòõòñ,þ€E". †‡ˆ‰2./‚=<6”•––<%ƒ -4)¡¢£¤¢1.;9&­®¯°®2!:¹º»¼º7 BÅÆÇÈdž+'ÏÐÑÒц8,( ÙÚÛÜÛ†>53'ãäåæåß- ìíîïî†9-Dö÷øùø†* (ß *\Èp¡¡=j0˜H±¢ÅŠ†HD°Ñ £Ç ?fŒð †É“(S¢4 „0cÊœ)ÓP 8nèÜɳ'O›@.XJ´¨Ñ¢PØðÇӧP£>Íá`G 0hÝʵëÖŒbpС¬Ù³hÍ ha¤Ä 0FÈK—.Ö!DrA+‘ßC‹Zè ;tcltk2/inst/tklibs/ttktheme_radiance/radiance/toolbutton-n.gif0000644000176200001440000000124014656355210024302 0ustar liggesusersGIF87aÆäßÙÔÍÆëçãüûúúùøø÷öÎÆ¿ÛÔÏ×ÐËãÞÚâÞÙñîëúø÷÷öôöôóõôòþþþüüüèãÞæáÜâÝØñíêíéæìéåù÷õ÷õóöóòõóñýýüüûûûûúÔÌÆÓÌÅÞØÓÎÆÀÛÖÐõòðòðíûúùùø÷ÏÇÀëçâÛÕÏêåáØÑÌæáÝõñïóïíâÝÙêçäöõóõóòÿÿÿýýýëæáÙÒÌØÐËäàÚãÞÙðìéïìèíêæÛÖÑøöôöôòôòðýüüüüû,þ€@0"‡ˆ‰‰(A‚8>4•–——2! #5¡¢£¤¤*: «¬­®®3(Bµ¶·¸¸B(&¿ÀÁ‡BÈÉÊËËB‡C'ÑÒÓÔÔC‡ÚÛÜÝ݇ ãäåææ‡&ìíîïï&ê@ôõö÷÷ò Aýþÿ28„¡„Áƒ&ÄpèÇ‚‡#J”øãP3jܸ1Ã! BŠI’¤†C$¨\ɲeK‡\¬˜I³¦M›.  x!¡§ÏŸ@¾@¢G‹ H“*]š´Å…Fl˜JµªÕ©9RÜHÇ ;*ˆK–ìŽ7Xl¤C–¢·ˆ%X;tcltk2/inst/tklibs/ttktheme_radiance/radiance/check-nc.gif0000644000176200001440000000116614656355210023320 0ustar liggesusersGIF89aÆlyC-zD-|G2€H1ŒP8Q7—P5­Q,—W=^Lœ[?¡^B¸[6¦aE´a@´bA¿c>¹mPwg¾qSÀsTÁsUÂtTêo=ÃxZëp@ëq?ëq@ìrAË|]ívEíwGèyLèzLïyIê|Pð{LÖ_ê}Qò|Mó~OóPò€Qó€Qô‚Qô‚SõƒVõ„Vö„Tö†YöˆZ÷ˆ[ö‰[ö‰\ø‰Zçh÷Š]øŠ\÷‹_ø`øbúŽaùdøeΛ‡ú’hÎœ‡Ô›ƒÏˆù”kö•nõ–oú•lö–nú•mú–mú—mú—nü—lü—nù˜pû˜oòšxû™qü™qüšrû›tüœuÀª¡óŸ}üŸ{ü£~ü£ü¤€ü¦‚þ®þ±‘ÙÌÄàÕÏëçåëêèìêéíëéîìêðìéðíêðîìöôòÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!þCreated with GIMP!ù ,¾€h@…†…BhibDY_`’“_YC R\A>Ÿ A[Va^<8«¬8;S Xk]3N1/º/2Q±g´ZFK-)).¾ f´W H'(M±G ÏTÒÓHL±7Ue´JIÓ±%:Eè´?$ìîîA?õjh‘@ƒ'6Ð8@f*.|0bÁVŒxÐH,`ØèÑ# !(i8†¡C†£fM ;tcltk2/inst/tklibs/ttktheme_radiance/radiance/comboarrow-d.gif0000644000176200001440000000060514656355210024235 0ustar liggesusersGIF87a¥ÜÕÎÚÓÌÙÓË×ÑÉÖÍÈâÝ×ßÙÔíéåìéäëçãéåáöóñþýü×ÐÈż³ÔÌÅâÜÖîêåíèäëæâñîëøöõôòñþþþÁ·®ÙÓÌÉÁ¹ÕÏÈÕÍÈîëçíéæëçäçãàõóñýýüüûûÞØÐÚÔÌÉÀ¸ÞØÓìèäôòïñîìƽ´ÒËù°áÛÕìçãçáÞáÚÔÜÖÏÈÀ¸ÖÎÉåàÛîêçìèåéæâöôòôòðóðï,ª@Ô"hAòÊH¸HgJ]Xb²„d»IPàðA5: Dx¦è2ƒÈ—½>ˆ~1ê÷k}y€~„a‚‡‰‡`Œ(5-““-7((+4+ ˜†a,39Ž¤`&+&ˆ­`0;6´ƒl¢»Š„™ÂI!‡v:¿€)%.#*Çlce 2' àá":' ( pHF%Ú(A;tcltk2/inst/tklibs/ttktheme_radiance/radiance/sbthumb-va.gif0000644000176200001440000000034214656355210023710 0ustar liggesusersGIF87a „×ÑÉäßÙúùøø÷ööõô×ÐÈßÚÓéäàïìéúø÷ööóþþþáÛÔÛÕÎîëçìéåþýýûûúîêæéæáùø÷áÛÕÛÕÏéåàëéåù÷ööõóýýýàÚÓÜÖÏáÜ×, g @] Pœ@s ¢Qa’#gD`Œ ¢$B/DϤñÐøŽ‚¥ á}“ãy\œ¦Ôžµ€Ín»ÔoV{ Äc´·œf¯ó`!D²MçØÜ‘A ˆ"&(Ž!;tcltk2/inst/tklibs/ttktheme_radiance/radiance/radio-dc.gif0000644000176200001440000000116614656355210023327 0ustar liggesusersGIF89aÆdÍÄ»ÏǾÐÇ¿ÐÈ¿ÑÈÁÑÉÀÒÉÂÒÊÂÓËÃÓÌÄÔÌÃÔÌÄÔÍÆÕÎÇÖÎÆÖÎÇÖÏÇÚÔÍÛÔÎÛÕÎÜÕÎÜÕÏÛÖÏÜÖÏÜ×ÐÝ×ÑÞ×ÒÝØÐÞØÑÞØÒÞØÓßÙÒßÙÓÞÚÔàÚÕáÚÖáÜÖåßÛåßÜæãÞæãßçäßèäàéåâêåâêæâêæäëæãëæäìæäêçãëçâëçãëçäìçãëèãìèãìèäìèåíèäìéåíéäíéåíéæíêæíêçîêæîêçîëéïëèïëéîìèîìéïìèïìéðìéïíêðíéðíêðíëñíêñîêñîëñîìòîëñïìòïëòïìòïíòðìóðíóðîôñîôñïòòïõòðöôòøöõø÷õù÷õÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!þCreated with GIMP!ù ,¾€``W((U‚`D*_cc_*^`R_XRWYR\]$b) [WNWTVSNVZ L%PJE KMQ&NCKÌEEI O?? Í CAOJ<@ Ù B?F/6<Ù>:0";4.ˆ59=#,œ Ђƌ4nÔÀACF$R&4XƒÅ‹‹/V4!Œ <¨¨QCŇ Â8sdÂT@ÒL ;tcltk2/inst/tklibs/ttktheme_radiance/radiance/tree-d.gif0000644000176200001440000000055614656355210023027 0ustar liggesusersGIF87a¥ÜÕÎÚÓÌÙÓË×ÑÉâÝ×íéåìéäëçãéåáöóñþýü×ÐÈâÜÖîêåíèäñîëôòñþþþÙÓÌîëçëçäõóñýýüüûûÞØÐÚÔÌÞØÓìèäôòïñîìáÛÕìçãáÚÔÜÖÏîêçìèåéæâôòð,“À …!XÈä@ÂøCRcB­Z­ (t``D#ÇfL.— ‹†@Ìðø£$4Äñü¸`,&zF€‚y„‡ˆ…‹q‰†Že’f”•d—˜ƒ›œŠžš˜¢•¤’¦Ž„›|%› ­‹hj! ÆÇÈÈ%uIÔGÀA;tcltk2/inst/tklibs/ttktheme_radiance/radiance/toolbutton-p.gif0000644000176200001440000000126314656355210024311 0ustar liggesusersGIF87aÆÊÁ¹ÙÓËÙÑËØÑÊ×ÑÉ×ÏÉÄ»³àÛÕÌžìçäÛÕÐÊüêåâèãàæáÞôñïÖÎÇÔÎÅÔÌÅâÜÖÒÊÃáÚÕàÚÔßØÓÞØÒÊ»éäàçâÞåàÜÒËÂÐÉÀÎǾÝ×н³ªÜÕÏÛÕÎÚÓÍÊÁºÉÁ¹åáÛäßÚßÛÕíéæéåâõóñäáÝÝÖÏÛÔÍ˺ÙÒËÉÀ¸ØÒÊ×ÐÉÖÐÈäÞÙÔÌÆÓÌÅãÜØÐÊÂêæâÚÔÏÙÔÎõòðÖÏÇÔÍÅÄ»²ÓËÄáÛÕÐÉÁßÙÓÝ×ÑÙÓÍæáÝãßÚíéçóñðÔÌÄÒÊÂÞØÑÜÖϼ²©ÚÔÍÙÒÌÉÀ¹åàÛäàÚãÞÙâÜØáÜ×ÐÊÃîêçìèåÜÖÒëæäçâàöôò,þ€_>=A!P‡ˆ‰‰!G‚&U'•–——U)%,ž@01 „ׯ`Á!ñ£Š( (th¢¨-¢&ÊD‘;tcltk2/inst/tklibs/ttktheme_radiance/radiance/sbthumb-ha.gif0000644000176200001440000000033514656355210023674 0ustar liggesusersGIF87a „×ÑÉäßÙúùøø÷ööõô×ÐÈßÚÓéäàïìéúø÷ööóþþþáÛÔÛÕÎîëçìéåþýýûûúîêæéæáùø÷áÛÕÛÕÏéåàëéåù÷ööõóýýýàÚÓÜÖÏáÜ×, b @]MažhXG&Ì#9tmgD`Œ¢%‚ p(ˆl<“FAl # @t:7€‚Ãj]˜¶Ü¦W«\å!¶Aˆ¤ƒMçظËFäÀà!@€‚"R))ˆ!;tcltk2/inst/tklibs/ttktheme_radiance/radiance/combo-rn.gif0000644000176200001440000000070414656355210023356 0ustar liggesusersGIF87a¥äßÙÔÍÆëçãüûúúùøø÷öÎÆ¿ÛÔÏãÞÚâÞÙñîëúø÷÷öôöôóõôòþþþüüüèãÞæáÜâÝØñíêíéæù÷õ÷õóöóòõóñýýüüûûûûúÔÌÆÓÌÅÞØÓÎÆÀÛÖÐõòðòðíûúùùø÷ÏÇÀëçâêåáæáÝõñïóïíâÝÙêçäöõóÿÿÿýýýëæáÙÒÌØÐËäàÚãÞÙðìéïìèíêæÛÖÑøöôöôòôòðýüüüüû,éÀ]†ŽÈ¤Ò`êL2³\ãñªZ¯Ø×ÃõI„`à°xL†y´zÍnCL½|N¯Û iÏïûÿ$=„…†‡ˆ>%Ž‘%–—˜™š Ÿ ¡¢£ $¨©ª«¬¦;°±²³´; <¹º»¼½<#ÂÃÄÅÆ#: ËÌÍÎÏ 7ÔÕÖ×Ø7ÝÞßàá"æçèéê*(ïðñòó(&+øùúûü8)$H°`ÁÄÀ°¡Ã‡iœà1C†2jÜÈ‘‚2„Ôè`b‰I$M;tcltk2/inst/tklibs/ttktheme_radiance/radiance/sbthumb-hn.gif0000644000176200001440000000050514656355210023710 0ustar liggesusersGIF87a ¥ÜÕÎÛÕÍ×ÑÉãÝØàÛÕöóñôñïø÷ö×ÐÈÞØÒïìéôòñþþþîëçöõòõóñþýýýýüîêæõòðõôóçãÞù÷ööõóýýýàÚÓßØÒÛÔÎçâÝëèäøöôöôòóòï, jÀσ@H„`Ù™Ž¤A­Z=”Ab˜Q Ÿ°xü±D•@Dn‹—@v»1DÃng÷|m~z‚J…dx‰a‰fh   ¡¢BrII¨A;tcltk2/inst/tklibs/ttktheme_radiance/radiance/comboarrow-a.gif0000644000176200001440000000057514656355210024240 0ustar liggesusersGIF87a¥×ÑÉâÝ×úùøø÷ööõôôóò×ÐÈßÚÓ  Ÿžžéäàõòïïìéúø÷ööóþþþ‚‚xxwttsÛÕÎîëçìéåþýýûûúîííàÚÕîêæéæáõò𘘘ÅÅÄùø÷ãâáÛÕÏŸŸžéåàëéåù÷ööõóýýý{{zàÚÓoonÜÖÏíêæ‚‚€||z,¢@Ág41@HQËcJå‡aàtx¿‚†‰‘ÙL]°ÚQ ,êø‡0<âqŠñŽëí}~{_|„†„^‰ * Œ(  (‹ƒ_""… ^-.-§€` ”¯‡_j–º}z „s$„l+  & qbdÙÚ,)ÁnHF+ÁA;tcltk2/inst/tklibs/ttktheme_radiance/radiance/button-a.gif0000644000176200001440000000200214656355210023364 0ustar liggesusersGIF89aÆw¦|h§}i¨~j©kª€l«m¬‚n®ƒo¯„p°…q±†r¯‡w°ˆx±‰y´‹{¯{µŒ|°Ž|»{¼‘|¹–„À•€º—…¸—‹ïf¼™‡ðŽgìgòhí‘hÆš…ï’iÇ›†î’oð“jï“pñ”kð”qò•lÊž‰ñ•r ”ó–må™|ò—r¾£•æš}î™rô˜sõ™tñ›töšuòœuóvò|ôžwõŸxôŸ~ö yõ ö¡€ù¢{ø¢ù¤‚ô¦‚ú¥ƒö§ƒû¦„÷¨„ø©…÷©‹Ì³ªùª†ù«É·¬Ê¸®û­ý®ð³œù²‘최ú³’ù³˜Õ¼³û´“î·žú´™ûµšÒÀµÓÁ¶ù¹œúºþÀ¨ù¨äÞÝàâßæáßçâàèãâêäãäæãëåäìæåæèåíçæçéæîèçéëèïêèðëéñìêóíìôîíîðíõïîöðï÷ñðøóñùôòÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!þCreated with GIMP!ù ,þ€v‚sp…†‡ˆ‰s‚‚tnY’“”•”Sntvun- U]\£¤¥¦£]U')nurXTE³HH´µ¶³´E¶HRYrqNDºEÆȳɺÆÌPqo [DDAÖÙØÖBÙÞÖA[ on [ØABAëêBB?îñDòá nn ZA?üý>ÿûýðo - Ü´Ypeà?<|@œH‘â¿W´i“Àʉ:BŠIRDT´Yƒ J:rà˜y£æ 7gêıƒG(Ö°AЄÎ5’*­AƒÆÒ6qðx‚€ÍšMtàT:#ÆŒ¦`Ã:½É£É5j0ÑqãkŒ·þoQÈ+WFŒ¦5t09 M$8hÈAW® …뢠q#I4iþÞ ƒ®‰Ë—I`6A—±ã4f ©QEf$R«V}YnŒF ˜9S H ¹%T‹ø b÷‡ß¿SÏ­¤À™2„Ðx¢„À;ü–¼7çÅB”A‰ÞÒ;tØ0^¼ù½I ˆáCû˜<*ƒÏƒ}ûîK¾ÞÇ€1ïí ×|Ô·Á÷Ù·Ÿ&ÄÀÃc ƒi»‰w‚x u ¢ ƒc„1€ ÍUÈAø¡˜ û…À™ „1Æ.4G‚oá}pp¼‰0g.D0ÆGT0W HæLf’«¥†ds(È0ÁkÌáŬ°^Sp×[\Ò°‚€±Éa(ñ@´éæ›p¶ÀK„#s¨AÆ|öéçŸ~’¡Æ"v;tcltk2/inst/tklibs/ttktheme_radiance/radiance/scale-ha.gif0000644000176200001440000000056114656355210023320 0ustar liggesusersGIF87a ¥È¿·Ä»³ÑÉÃÌž×ÑÌïíêíëèúùøÖÐÊøöõÈ¿¸Ã»³ÓËÆÒËÅïëèõóñïíëýýüûûúȾ·Ãº²âÜ×ÑÊÃéäáæâÞõòðäàÜîìéíêèìêçûúùìçãÕÏÉäßÛòïìíëçëçåÿÿÿǾ·îêçÚÔÐéæâöôòþþýüüû, –À!° ȤÒ "†FYY¯Ø¬Ѐ •*(DÎè´:]¤Ä‘x Ø°îø¼þ¾qÏOsc&†%ˆŠ‰‡~s‚ƒ–‰˜˜o“ ƒ‰¥%§&Ÿ¡ )&$ ‰³%µ$¬®º°‰¾‰¹º»&"ÇÇÂÃÄ!Ï!ËÌÄÒÓÄ(Ø®A;tcltk2/inst/tklibs/ttktheme_radiance/radiance/radio-nu.gif0000644000176200001440000000106414656355210023360 0ustar liggesusersGIF89aÆ@±¦›·­£¸®£º¯¥¹°¦º°§»²©¼³©¼³ªÀ·­À·®Â¸®Äº²Ä»²Æ½´Ç¾µÇ¾¶Æ¿·Ç¿¶Ç¿·ÊºËûÍĽÌżÎÇ¿ÏÈÁÐÈÁÑÉÃÓÌÄÔÍÆÖÐÊ×ÐÉØÑÊÝÚÕÞÚÕßÛ×àÜÖáÜØáÝØâßÙãßÛäßÛåáÝèåâëèåëéåìéæîëèñîëñïìòïìññîòòîöôòöõô÷õô÷öõøöõø÷õûúùûúúûûúüûûþþþÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!þCreated with GIMP!ù ,|€552!"1‚5/#6??6#350=@¡¢=:$ ¢«;+&«²@%7³«6?¹¢?¾¿@? 8Å@7 )Ë(' <¿< ,0>³>:54*8•8* 9Ž:- .ã5;tcltk2/inst/tklibs/ttktheme_radiance/radiance/arrowdown-n.gif0000644000176200001440000000054614656355210024123 0ustar liggesusersGIF87a¥ÜÕÎÛÕÍ×ÑÉáÛÖöóñôñïø÷ö×ÐÈáÜÕÞØÒôðîôòñðîíþþþ€€zzyßÞÜnnmžœ›œ›š——•îëçõóñþýýëéçzyxwwuîêæëèãõòðõôóáÛÕßÙÓçãÞôñîù÷ööõóýýýssrßØÒÛÔÎçâÝïìèíêæëèäÃÁÀöôòóòïzzx,‹@Øe8Õê#L L˜†TJr…CÄ©ëz –h¼ènÌ¥`ÒéKKphÀÓ£‚Šøý(0yu]/2/]„v]^^  — ^‚]r.1hh1+,i`b# ".ÂÂ-")£#mGF#£A;tcltk2/inst/tklibs/ttktheme_radiance/radiance/tree-h.gif0000644000176200001440000000040114656355210023020 0ustar liggesusersGIF87a„×ÑÉâÝ×úùøø÷ööõô×ÐÈßÚÓéäàõòïïìéúø÷ööóþþþÛÕÎîëçìéåþýýûûúàÚÕîêæéæáõòðùø÷ÛÕÏéåàëéåù÷ööõóýýýàÚÓÜÖÏíêæ,† `aMažh \‡&1tmÛUcÀE‚ pHTlJƒ$:‹ÇyZ‡– À¸zS÷k sÉe1úi¯‡í71.Òë`5>ÞßëroƒkaxY  xQ  kFH¢£¤¤ŠS)¯'Š!;tcltk2/inst/tklibs/ttktheme_radiance/radiance/arrowright-d.gif0000644000176200001440000000055414656355210024256 0ustar liggesusersGIF87a¥ÜÕÎÚÓÌÙÓËÉÁ¸×ÑÉÖÍÈâÝ×ßÙÔíéåìéäëçãéåáþýü×ÐÈż³âÜÖîêåíèäëæâéæàÕÎÉäàÛñîëøöõôòñþþþÁ·®ßÙÒÙÓÌÕÏÈÕÍÈñíêîëçíéæëçäêçãéåâçãàóñïüûûÚÔÌÉÀ¸ÈÀ·Æ¼µÓÌÅíêåìèäéæáñîìǽµÒËù°Ý×ÑìçãßØÒÜÖÏÉÀ¹çâÝòîëîêçìèåéæâöôòôòð,‘@—è!hΣ&¼m0ŒŒTª#ÙnŠÇæC¸¾ßoG3~püM¼8†÷;;°]-B#ÃÖÄX` F|`)9_ƒ{}21!.…_*8&i–}+;Œ l3%>ly `#i` (6;<wbd 74= ÇÇ-/4 . pGF(Á.A;tcltk2/inst/tklibs/ttktheme_radiance/pkgIndex.tcl0000644000176200001440000000062414656355210021663 0ustar liggesusers# Package index for tile demo pixmap themes. if {[file isdirectory [file join $dir radiance]]} { if {[package vsatisfies [package require tile] 0.8.0]} { package ifneeded ttk::theme::radiance 0.1 \ [list source [file join $dir radiance8.5.tcl]] } else { package ifneeded tile::theme::radiance 0.1 \ [list source [file join $dir radiance8.4.tcl]] } } tcltk2/inst/tklibs/ttktheme_radiance/radiance8.5.tcl0000644000176200001440000002674214656355210022124 0ustar liggesusers# radiance.tcl ## TODO: make default button a little bit darker namespace eval ttk::theme::radiance { package provide ttk::theme::radiance 0.1 proc LoadImages {imgdir {patterns {*.gif}}} { foreach pattern $patterns { foreach file [glob -directory $imgdir $pattern] { set img [file tail [file rootname $file]] if {![info exists images($img)]} { set images($img) [image create photo -file $file] } } } return [array get images] } variable I array set I [LoadImages \ [file join [file dirname [info script]] radiance] *.gif] variable colors array set colors { -frame "#f6f4f2" -lighter "#f9f9f9" -dark "#d1c8c0" -darker "#c3bab0" -darkest "#a89c91" -selectbg "#ed7442" -selectfg "#ffffff" -disabledfg "#9e928a" -entryfocus "#6f9dc6" -tabbg "#c9c1bc" -tabborder "#b5aca7" -troughcolor "#d7cbbe" -troughborder "#ae9e8e" -checklight "#f5f3f0" -text "#62564f" } #PhG: change fonts... should not fail if font is not there! font configure TkDefaultFont -family Ubuntu -size 11 ttk::style theme create radiance -parent clam -settings { ttk::style configure . \ -borderwidth 1 \ -background $colors(-frame) \ -foreground $colors(-text) \ -bordercolor $colors(-darkest) \ -darkcolor $colors(-dark) \ -lightcolor $colors(-lighter) \ -troughcolor $colors(-troughcolor) \ -selectforeground $colors(-selectfg) \ -selectbackground $colors(-selectbg) \ -font TkDefaultFont \ ; ttk::style map . \ -background [list disabled $colors(-frame) \ active $colors(-lighter)] \ -foreground [list disabled $colors(-disabledfg)] \ -selectbackground [list !focus $colors(-darker)] \ -selectforeground [list !focus white] \ ; # ttk::style configure Frame.border -relief groove ## Treeview. # ttk::style element create Treeheading.cell image \ [list $I(tree-n) \ selected $I(tree-p) \ disabled $I(tree-d) \ pressed $I(tree-p) \ active $I(tree-h) \ ] \ -border 4 -sticky ew ##PhG: TODO: check this #ttk::style configure Treeview -fieldbackground white ttk::style configure Row -background "#efefef" ttk::style map Row -background [list \ {focus selected} "#71869e" \ selected "#969286" \ alternate white] ttk::style map Item -foreground [list selected white] ttk::style map Cell -foreground [list selected white] ## Buttons. # ttk::style configure TButton -width -11 -anchor center ttk::style configure TButton -padding {10 0} ttk::style layout TButton { Button.focus -children { Button.button -children { Button.padding -children { Button.label } } } } #PhG = OK! except selection box ttk::style element create Button.button image \ [list $I(button-n) \ pressed $I(button-p) \ {selected active} $I(button-sa) \ selected $I(button-s) \ active $I(button-a) \ disabled $I(button-d) \ ] \ -border 8 -sticky ew ## Checkbuttons. # ttk::style element create Checkbutton.indicator image \ [list $I(check-nu) \ {disabled selected} $I(check-dc) \ disabled $I(check-du) \ {pressed selected} $I(check-nc) \ pressed $I(check-nu) \ {active selected} $I(check-nc) \ active $I(check-nu) \ selected $I(check-nc) ] \ -width 24 -sticky w ttk::style map TCheckbutton -background [list active $colors(-checklight)] ttk::style configure TCheckbutton -padding 1 ## Radiobuttons. # ttk::style element create Radiobutton.indicator image \ [list $I(radio-nu) \ {disabled selected} $I(radio-dc) \ disabled $I(radio-du) \ {pressed selected} $I(radio-nc) \ pressed $I(radio-nu) \ {active selected} $I(radio-nc) \ active $I(radio-nu) \ selected $I(radio-nc) ] \ -width 24 -sticky w ttk::style map TRadiobutton -background [list active $colors(-checklight)] ttk::style configure TRadiobutton -padding 1 ## Menubuttons. # #ttk::style configure TMenubutton -relief raised -padding {10 2} # ttk::style element create Menubutton.border image $I(toolbutton-n) \ # -map [list \ # pressed $I(toolbutton-p) \ # selected $I(toolbutton-p) \ # active $I(toolbutton-a) \ # disabled $I(toolbutton-n)] \ # -border {4 7 4 7} -sticky nsew ttk::style element create Menubutton.border image \ [list $I(button-n) \ selected $I(button-p) \ disabled $I(button-d) \ active $I(button-a) \ ] \ -border 4 -sticky ew ## Toolbar buttons. # ###PhG added ttk::style configure Toolbutton -anchor center ttk::style configure Toolbutton -padding -5 -relief flat ttk::style configure Toolbutton.label -padding 0 -relief flat ttk::style element create Toolbutton.border image \ [list $I(blank) \ pressed $I(toolbutton-p) \ {selected active} $I(toolbutton-pa) \ selected $I(toolbutton-p) \ active $I(toolbutton-a) \ disabled $I(blank)] \ -border 11 -sticky nsew ## Entry widgets. # ttk::style configure TEntry -padding 1 -insertwidth 1 \ -fieldbackground white ttk::style map TEntry \ -fieldbackground [list readonly $colors(-frame)] \ -bordercolor [list focus $colors(-selectbg)] \ -lightcolor [list focus $colors(-entryfocus)] \ -darkcolor [list focus $colors(-entryfocus)] \ ; ## Combobox. # ttk::style configure TCombobox -selectbackground ttk::style element create Combobox.downarrow image \ [list $I(comboarrow-n) \ disabled $I(comboarrow-d) \ pressed $I(comboarrow-p) \ active $I(comboarrow-a) \ ] \ -border 1 -sticky {} ttk::style element create Combobox.field image \ [list $I(combo-n) \ {readonly disabled} $I(combo-rd) \ {readonly pressed} $I(combo-rp) \ {readonly focus} $I(combo-rf) \ readonly $I(combo-rn) \ ] \ -border 4 -sticky ew ## Notebooks. # # ttk::style element create tab image $I(tab-a) -border {2 2 2 0} \ # -map [list selected $I(tab-n)] ttk::style configure TNotebook.Tab -padding {6 2 6 2} ttk::style map TNotebook.Tab \ -padding [list selected {6 4 6 2}] \ -background [list selected $colors(-frame) {} $colors(-tabbg)] \ -lightcolor [list selected $colors(-lighter) {} $colors(-dark)] \ -bordercolor [list selected $colors(-darkest) {} $colors(-tabborder)] \ ; ## Labelframes. # ttk::style configure TLabelframe -borderwidth 2 -relief groove ## Scrollbars. # ttk::style layout Vertical.TScrollbar { Scrollbar.trough -sticky ns -children { Scrollbar.uparrow -side top Scrollbar.downarrow -side bottom Vertical.Scrollbar.thumb -side top -expand true -sticky ns } } ttk::style layout Horizontal.TScrollbar { Scrollbar.trough -sticky we -children { Scrollbar.leftarrow -side left Scrollbar.rightarrow -side right Horizontal.Scrollbar.thumb -side left -expand true -sticky we } } ttk::style element create Horizontal.Scrollbar.thumb image \ [list $I(sbthumb-hn) \ disabled $I(sbthumb-hd) \ pressed $I(sbthumb-ha) \ active $I(sbthumb-ha)] \ -border 3 ttk::style element create Vertical.Scrollbar.thumb image \ [list $I(sbthumb-vn) \ disabled $I(sbthumb-vd) \ pressed $I(sbthumb-va) \ active $I(sbthumb-va)] \ -border 3 foreach dir {up down left right} { ttk::style element create ${dir}arrow image \ [list $I(arrow${dir}-n) \ disabled $I(arrow${dir}-d) \ pressed $I(arrow${dir}-p) \ active $I(arrow${dir}-a)] \ -border 1 -sticky {} } ttk::style configure TScrollbar -bordercolor $colors(-troughborder) ## Scales. # ttk::style element create Scale.slider image \ [list $I(scale-hn) \ disabled $I(scale-hd) \ active $I(scale-ha) \ ] ttk::style element create Scale.trough image $I(scaletrough-h) \ -border 2 -sticky ew -padding 0 ttk::style element create Vertical.Scale.slider image \ [list $I(scale-vn) \ disabled $I(scale-vd) \ active $I(scale-va) \ ] ttk::style element create Vertical.Scale.trough image $I(scaletrough-v) \ -border 2 -sticky ns -padding 0 ttk::style configure TScale -bordercolor $colors(-troughborder) ## Progressbar. # ttk::style element create Horizontal.Progressbar.pbar image $I(progress-h) \ -border {2 2 1 1} ttk::style element create Vertical.Progressbar.pbar image $I(progress-v) \ -border {2 2 1 1} ttk::style configure TProgressbar -bordercolor $colors(-troughborder) ## Statusbar parts. # ttk::style element create sizegrip image $I(sizegrip) ## Paned window parts. # # ttk::style element create hsash image $I(hseparator-n) -border {2 0} \ # -map [list {active !disabled} $I(hseparator-a)] # ttk::style element create vsash image $I(vseparator-n) -border {0 2} \ # -map [list {active !disabled} $I(vseparator-a)] ttk::style configure Sash -sashthickness 6 -gripcount 16 ## Separator. # #ttk::style element create separator image $I(sep-h) #ttk::style element create hseparator image $I(sep-h) #ttk::style element create vseparator image $I(sep-v) } } tcltk2/inst/tklibs/ttktheme_radiance/radiance8.4.tcl0000644000176200001440000002542014656355210022113 0ustar liggesusers# radiance.tcl namespace eval tile::theme::radiance { package provide tile::theme::radiance 0.1 variable I array set I [tile::LoadImages \ [file join [file dirname [info script]] radiance] *.gif] variable colors array set colors { -frame "#efebe7" -lighter "#f5f3f0" -dark "#cfcdc8" -darker "#9e9a9e" -darkest "#d4cfca" -selectbg "#7c99ad" -selectfg "#ffffff" -disabledfg "#b5b3ac" -entryfocus "#6f9dc6" -tabbg "#c9c1bc" -tabborder "#b5aca7" -troughcolor "#d7cbbe" -troughborder "#ae9e8e" -checklight "#f5f3f0" } style theme create radiance -parent clam -settings { style configure . \ -borderwidth 1 \ -background $colors(-frame) \ -foreground black \ -bordercolor $colors(-darkest) \ -darkcolor $colors(-dark) \ -lightcolor $colors(-lighter) \ -troughcolor $colors(-troughcolor) \ -selectforeground $colors(-selectfg) \ -selectbackground $colors(-selectbg) \ -font TkDefaultFont \ ; style map . \ -background [list disabled $colors(-frame) \ active $colors(-lighter)] \ -foreground [list disabled $colors(-disabledfg)] \ -selectbackground [list !focus $colors(-darker)] \ -selectforeground [list !focus white] \ ; # style configure Frame.border -relief groove ## Treeview. # style element create Treeheading.cell image $I(tree-n) \ -map [list \ selected $I(tree-p) \ disabled $I(tree-d) \ pressed $I(tree-p) \ active $I(tree-h) \ ] \ -border 4 -sticky ew #style configure Treeview -fieldbackground white style configure Row -background "#efefef" style map Row -background [list \ {focus selected} "#71869e" \ selected "#969286" \ alternate white] style map Item -foreground [list selected white] style map Cell -foreground [list selected white] ## Buttons. # #style configure TButton -padding {10 0} -anchor center style configure TButton -padding {5 5} -anchor center -width -9 style layout TButton { Button.button -children { Button.focus -children { Button.padding -children { Button.label } } } } style element create button image $I(button-n) \ -map [list \ pressed $I(button-p) \ {selected active} $I(button-pa) \ selected $I(button-p) \ active $I(button-a) \ disabled $I(button-d) \ ] \ -border 4 -sticky ew ## Checkbuttons. # style element create Checkbutton.indicator image $I(check-nu) \ -width 24 -sticky w -map [list \ {disabled selected} $I(check-dc) \ disabled $I(check-du) \ {pressed selected} $I(check-pc) \ pressed $I(check-pu) \ {active selected} $I(check-ac) \ active $I(check-au) \ selected $I(check-nc) ] style map TCheckbutton -background [list active $colors(-checklight)] style configure TCheckbutton -padding 1 ## Radiobuttons. # style element create Radiobutton.indicator image $I(radio-nu) \ -width 24 -sticky w \ -map [list \ {disabled selected} $I(radio-dc) \ disabled $I(radio-du) \ {pressed selected} $I(radio-pc) \ pressed $I(radio-pu) \ {active selected} $I(radio-ac) \ active $I(radio-au) \ selected $I(radio-nc) ] style map TRadiobutton -background [list active $colors(-checklight)] style configure TRadiobutton -padding 1 ## Menubuttons. # #style configure TMenubutton -relief raised -padding {10 2} # style element create Menubutton.border image $I(toolbutton-n) \ # -map [list \ # pressed $I(toolbutton-p) \ # selected $I(toolbutton-p) \ # active $I(toolbutton-a) \ # disabled $I(toolbutton-n)] \ # -border {4 7 4 7} -sticky nsew style element create Menubutton.border image $I(button-n) \ -map [list \ selected $I(button-p) \ disabled $I(button-d) \ active $I(button-a) \ ] \ -border 4 -sticky ew ## Toolbar buttons. # style configure Toolbutton -padding -5 -relief flat style configure Toolbutton.label -padding 0 -relief flat style element create Toolbutton.border image $I(blank) \ -map [list \ pressed $I(toolbutton-p) \ {selected active} $I(toolbutton-pa) \ selected $I(toolbutton-p) \ active $I(toolbutton-a) \ disabled $I(blank)] \ -border 11 -sticky nsew ## Entry widgets. # style configure TEntry -padding 1 -insertwidth 1 \ -fieldbackground white style map TEntry \ -fieldbackground [list readonly $colors(-frame)] \ -bordercolor [list focus $colors(-selectbg)] \ -lightcolor [list focus $colors(-entryfocus)] \ -darkcolor [list focus $colors(-entryfocus)] \ ; ## Combobox. # style configure TCombobox -selectbackground style element create Combobox.downarrow image $I(comboarrow-n) \ -map [list \ disabled $I(comboarrow-d) \ pressed $I(comboarrow-p) \ active $I(comboarrow-a) \ ] \ -border 1 -sticky {} style element create Combobox.field image $I(combo-n) \ -map [list \ {readonly disabled} $I(combo-rd) \ {readonly pressed} $I(combo-rp) \ {readonly focus} $I(combo-rf) \ readonly $I(combo-rn) ] \ -border 4 -sticky ew ## Notebooks. # # style element create tab image $I(tab-a) -border {2 2 2 0} \ # -map [list selected $I(tab-n)] style configure TNotebook.Tab -padding {6 2 6 2} style map TNotebook.Tab \ -padding [list selected {6 4 6 2}] \ -background [list selected $colors(-frame) {} $colors(-tabbg)] \ -lightcolor [list selected $colors(-lighter) {} $colors(-dark)] \ -bordercolor [list selected $colors(-darkest) {} $colors(-tabborder)] \ ; ## Labelframes. # style configure TLabelframe -borderwidth 2 -relief groove ## Scrollbars. # style layout Vertical.TScrollbar { Scrollbar.trough -sticky ns -children { Scrollbar.uparrow -side top Scrollbar.downarrow -side bottom Vertical.Scrollbar.thumb -side top -expand true -sticky ns } } style layout Horizontal.TScrollbar { Scrollbar.trough -sticky we -children { Scrollbar.leftarrow -side left Scrollbar.rightarrow -side right Horizontal.Scrollbar.thumb -side left -expand true -sticky we } } style element create Horizontal.Scrollbar.thumb image $I(sbthumb-hn) \ -map [list \ disabled $I(sbthumb-hd) \ pressed $I(sbthumb-ha) \ active $I(sbthumb-ha)] \ -border 3 style element create Vertical.Scrollbar.thumb image $I(sbthumb-vn) \ -map [list \ disabled $I(sbthumb-vd) \ pressed $I(sbthumb-va) \ active $I(sbthumb-va)] \ -border 3 foreach dir {up down left right} { style element create ${dir}arrow image $I(arrow${dir}-n) \ -map [list \ disabled $I(arrow${dir}-d) \ pressed $I(arrow${dir}-p) \ active $I(arrow${dir}-a)] \ -border 1 -sticky {} } style configure TScrollbar -bordercolor $colors(-troughborder) ## Scales. # style element create Scale.slider image $I(scale-hn) \ -map [list \ disabled $I(scale-hd) \ active $I(scale-ha) \ ] style element create Scale.trough image $I(scaletrough-h) \ -border 2 -sticky ew -padding 0 style element create Vertical.Scale.slider image $I(scale-vn) \ -map [list \ disabled $I(scale-vd) \ active $I(scale-va) \ ] style element create Vertical.Scale.trough image $I(scaletrough-v) \ -border 2 -sticky ns -padding 0 style configure TScale -bordercolor $colors(-troughborder) ## Progressbar. # style element create Horizontal.Progressbar.pbar image $I(progress-h) \ -border {2 2 1 1} style element create Vertical.Progressbar.pbar image $I(progress-v) \ -border {2 2 1 1} style configure TProgressbar -bordercolor $colors(-troughborder) ## Statusbar parts. # style element create sizegrip image $I(sizegrip) ## Paned window parts. # # style element create hsash image $I(hseparator-n) -border {2 0} \ # -map [list {active !disabled} $I(hseparator-a)] # style element create vsash image $I(vseparator-n) -border {0 2} \ # -map [list {active !disabled} $I(vseparator-a)] style configure Sash -sashthickness 6 -gripcount 16 ## Separator. # #style element create separator image $I(sep-h) #style element create hseparator image $I(sep-h) #style element create vseparator image $I(sep-v) } } tcltk2/inst/tklibs/autoscroll1.1/0000755000176200001440000000000015017102465016332 5ustar liggesuserstcltk2/inst/tklibs/autoscroll1.1/autoscroll.tcl0000644000176200001440000001570715017041713021235 0ustar liggesusers# autoscroll.tcl -- # # Package to create scroll bars that automatically appear when # a window is too small to display its content. # # Copyright (c) 2003 Kevin B Kenny # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: autoscroll.tcl,v 1.8 2005/06/01 02:37:51 andreas_kupries Exp $ package require Tk package provide autoscroll 1.1 namespace eval ::autoscroll { namespace export autoscroll unautoscroll bind Autoscroll [namespace code [list destroyed %W]] bind Autoscroll [namespace code [list map %W]] } #---------------------------------------------------------------------- # # ::autoscroll::autoscroll -- # # Create a scroll bar that disappears when it is not needed, and # reappears when it is. # # Parameters: # w -- Path name of the scroll bar, which should already exist # # Results: # None. # # Side effects: # The widget command is renamed, so that the 'set' command can # be intercepted and determine whether the widget should appear. # In addition, the 'Autoscroll' bind tag is added to the widget, # so that the event can be intercepted. # #---------------------------------------------------------------------- proc ::autoscroll::autoscroll { w } { if { [info commands ::autoscroll::renamed$w] != "" } { return $w } rename $w ::autoscroll::renamed$w interp alias {} ::$w {} ::autoscroll::widgetCommand $w bindtags $w [linsert [bindtags $w] 1 Autoscroll] eval [list ::$w set] [renamed$w get] return $w } #---------------------------------------------------------------------- # # ::autoscroll::unautoscroll -- # # Return a scrollbar to its normal static behavior by removing # it from the control of this package. # # Parameters: # w -- Path name of the scroll bar, which must have previously # had ::autoscroll::autoscroll called on it. # # Results: # None. # # Side effects: # The widget command is renamed to its original name. The widget # is mapped if it was not currently displayed. The widgets # bindtags are returned to their original state. Internal memory # is cleaned up. # #---------------------------------------------------------------------- proc ::autoscroll::unautoscroll { w } { if { [info commands ::autoscroll::renamed$w] != "" } { variable grid rename ::$w {} rename ::autoscroll::renamed$w ::$w if { [set i [lsearch -exact [bindtags $w] Autoscroll]] > -1 } { bindtags $w [lreplace [bindtags $w] $i $i] } if { [info exists grid($w)] } { eval [join $grid($w) \;] unset grid($w) } } } #---------------------------------------------------------------------- # # ::autoscroll::widgetCommand -- # # Widget command on an 'autoscroll' scrollbar # # Parameters: # w -- Path name of the scroll bar # command -- Widget command being executed # args -- Arguments to the commane # # Results: # Returns whatever the widget command returns # # Side effects: # Has whatever side effects the widget command has. In # addition, the 'set' widget command is handled specially, # by gridding/packing the scroll bar according to whether # it is required. # #------------------------------------------------------------ proc ::autoscroll::widgetCommand { w command args } { variable grid if { $command == "set" } { foreach { min max } $args {} if { $min <= 0 && $max >= 1 } { switch -exact -- [winfo manager $w] { grid { lappend grid($w) "[list grid $w] [grid info $w]" grid forget $w } pack { foreach x [pack slaves [winfo parent $w]] { lappend grid($w) "[list pack $x] [pack info $x]" } pack forget $w } } } elseif { [info exists grid($w)] } { eval [join $grid($w) \;] unset grid($w) } } return [eval [list renamed$w $command] $args] } #---------------------------------------------------------------------- # # ::autoscroll::destroyed -- # # Callback executed when an automatic scroll bar is destroyed. # # Parameters: # w -- Path name of the scroll bar # # Results: # None. # # Side effects: # Cleans up internal memory. # #---------------------------------------------------------------------- proc ::autoscroll::destroyed { w } { variable grid catch { unset grid($w) } rename ::$w {} } #---------------------------------------------------------------------- # # ::autoscroll::map -- # # Callback executed when an automatic scroll bar is mapped. # # Parameters: # w -- Path name of the scroll bar. # # Results: # None. # # Side effects: # Geometry of the scroll bar's top-level window is constrained. # # This procedure keeps the top-level window associated with an # automatic scroll bar from being resized automatically after the # scroll bar is mapped. This effect avoids a potential endless loop # in the case where the resize of the top-level window resizes the # widget being scrolled, causing the scroll bar no longer to be needed. # #---------------------------------------------------------------------- proc ::autoscroll::map { w } { wm geometry [winfo toplevel $w] [wm geometry [winfo toplevel $w]] } #---------------------------------------------------------------------- # # ::autoscroll::wrap -- # # Arrange for all new scrollbars to be automatically autoscrolled # # Parameters: # None. # # Results: # None. # # Side effects: # ::scrollbar is overloaded to automatically autoscroll any new # scrollbars. # #---------------------------------------------------------------------- proc ::autoscroll::wrap {} { if {[info commands ::autoscroll::_scrollbar] != ""} {return} rename ::scrollbar ::autoscroll::_scrollbar proc ::scrollbar {w args} { eval ::autoscroll::_scrollbar [list $w] $args ::autoscroll::autoscroll $w return $w } } #---------------------------------------------------------------------- # # ::autoscroll::unwrap -- # # Turns off automatic autoscrolling of new scrollbars. Does not # effect existing scrollbars. # # Parameters: # None. # # Results: # None. # # Side effects: # ::scrollbar is returned to its original state # #---------------------------------------------------------------------- proc ::autoscroll::unwrap {} { if {[info commands ::autoscroll::_scrollbar] == ""} {return} rename ::scrollbar {} rename ::autoscroll::_scrollbar ::scrollbar } tcltk2/inst/tklibs/autoscroll1.1/pkgIndex.tcl0000644000176200001440000000114415017041713020605 0ustar liggesusers# Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. if { ![package vsatisfies [package provide Tcl] 8.2-] } { return } package ifneeded autoscroll 1.1 [list source [file join $dir autoscroll.tcl]] tcltk2/inst/tklibs/autoscroll1.1/ChangeLog0000644000176200001440000000256515017041713020112 0ustar liggesusers2020-02-09 0.7 * * Released and tagged Tklib 0.7 ======================== * 2013-03-25 Andreas Kupries * * Released and tagged Tklib 0.6 ======================== * 2009-01-21 Andreas Kupries * * Released and tagged Tklib 0.5 ======================== * 2005-11-10 Andreas Kupries * * Released and tagged Tklib 0.4.1 ======================== * 2005-11-02 Andreas Kupries * * Released and tagged Tklib 0.4 ======================== * 2005-05-18 Andreas Kupries * autoscroll.tcl: Added missing 'require Tk'. 2005-04-01 Aaron Faupell * autoscroll.tcl: updated to not fail if autoscroll called twice on a the same scrollbar 2005-03-24 Aaron Faupell * bumped version number for new wrap commands 2005-03-24 Aaron Faupell * autoscroll.tcl: added commands wrap and unwrap * autoscroll.man: added docs for wrap and unwrap, and an example 2003-07-27 Aaron Faupell initial import 2000-09-18 Kevin Kenny * autoscroll.tcl: Initial version posted to http://wiki.tcl.tk/950tcltk2/inst/tklibs/autoscroll1.1/autoscroll.man0000644000176200001440000000401615017041713021215 0ustar liggesusers[comment {-*- tcl -*- doctools manpage}] [manpage_begin autoscroll n 1.1] [keywords scroll] [keywords scrollbar] [moddesc {Automatic mapping of scrollbars}] [titledesc {Provides for a scrollbar to automatically mapped and unmapped as needed}] [require Tcl] [require autoscroll [opt 1.1]] [description] This package allows scrollbars to be mapped and unmapped as needed depending on the size and content of the scrollbars scrolled widget. The scrollbar must be managed by either pack or grid, other geometry managers are not supported. [para] When managed by pack, any geometry changes made in the scrollbars parent between the time a scrollbar is unmapped, and when it is mapped will be lost. It is an error to destroy any of the scrollbars siblings while the scrollbar is unmapped. When managed by grid, if anything becomes gridded in the same row and column the scrollbar occupied it will be replaced by the scrollbar when remapped. [para] This package may be used on any scrollbar-like widget as long as it supports the [const set] subcommand in the same style as scrollbar. If the [const set] subcommand is not used then this package will have no effect. [para] [list_begin definitions] [call [cmd ::autoscroll::autoscroll] [arg scrollbar]] Arranges for the already existing scrollbar [const scrollbar] to be mapped and unmapped as needed. [call [cmd ::autoscroll::unautoscroll] [arg scrollbar]] Returns the named scrollbar to its original static state. [call [cmd ::autoscroll::wrap]] Arranges for all scrollbars created after this command is run to be automatically mapped and unmapped as needed. [call [cmd ::autoscroll::unwrap]] Turns off the automatic autoscrolling of all new scrollbars. Does not effect existing scrollbars [list_end] [example { text .t -yscrollcommand ".scrolly set" scrollbar .scrolly -orient v -command ".t yview" pack .scrolly -side right -fill y pack .t -side left -fill both -expand 1 ::autoscroll::autoscroll .scrolly }] [vset CATEGORY autoscroll] [include ../../support/devel/doc/feedback.inc] [manpage_end] tcltk2/inst/tklibs/autoscroll1.1/example.tcl0000644000176200001440000000036114656355210020477 0ustar liggesuserssource ./autoscroll.tcl text .t -highlightthickness 0 -yscrollcommand ".scrolly set" scrollbar .scrolly -orient v -command ".t yview" pack .scrolly -side right -fill y pack .t -side left -fill both -expand 1 ::autoscroll::autoscroll .scrollytcltk2/inst/tklibs/fonts.tcl0000755000176200001440000001272114656355210015574 0ustar liggesusers# This is the same fonts.tcl as in Tile,... but that can run independently # # $Id: fonts.tcl,v 1.16 2007/12/07 06:25:50 jenglish Exp $ # # Tile package: Font specifications. # # This file, [source]d from tile.tcl when the package is loaded, # sets up the following symbolic fonts based on the current platform: # # TkDefaultFont -- default for GUI items not otherwise specified # TkTextFont -- font for user text (entry, listbox, others) # TkFixedFont -- standard fixed width font # TkHeadingFont -- headings (column headings, etc) # TkCaptionFont -- dialog captions (primary text in alert dialogs, etc.) # TkTooltipFont -- font to use for tooltip windows # TkIconFont -- font to use for icon captions # TkMenuFont -- used to use for menu items # # In Tk 8.5, some of these fonts may be provided by the TIP#145 implementation # (On Windows and Mac OS X as of Oct 2007). # # The TIP, fonts(n) manpage, and implementation do not as of yet agree. # # +++ Platform notes: # # Windows: # The default system font changed from "MS Sans Serif" to "Tahoma" # in Windows XP/Windows 2000. # # MS documentation says to use "Tahoma 8" in Windows 2000/XP, # although many MS programs still use "MS Sans Serif 8" # # Should use SystemParametersInfo() instead. # # Mac OSX / Aqua: # Quoth the Apple HIG: # The _system font_ (Lucida Grande Regular 13 pt) is used for text # in menus, dialogs, and full-size controls. # [...] Use the _view font_ (Lucida Grande Regular 12pt) as the default # font of text in lists and tables. # [...] Use the _emphasized system font_ (Lucida Grande Bold 13 pt) # sparingly. It is used for the message text in alerts. # [...] The _small system font_ (Lucida Grande Regular 11 pt) [...] # is also the default font for column headings in lists, for help tags, # and for small controls. # # That document lies, however (see #780617). The font sizes # used below reflect what GetThemeFont() returns. # # Note that the font for column headings (TkHeadingFont) is # _smaller_ than the default font. # # There does not appear to be any recommendations for fixed-width fonts. # # Mac classic: # Don't know, can't find *anything* on the Web about Mac pre-OSX. # Might have used Geneva. Doesn't matter, this platform # isn't supported anymore anyway. # # X11: # Need a way to tell if Xft is enabled or not. # For now, assume patch #971980 applied. # # "Classic" look used Helvetica bold for everything except # for entry widgets, which use Helvetica medium. # Most other toolkits use medium weight for all UI elements, # which is what we do now. # # Font size specified in pixels on X11, not points. # This is Theoretically Wrong, but in practice works better; using # points leads to huge inconsistencies across different servers. # ###namespace eval ttk { catch {font create TkDefaultFont} catch {font create TkTextFont} catch {font create TkHeadingFont} catch {font create TkCaptionFont} catch {font create TkTooltipFont} catch {font create TkFixedFont} catch {font create TkIconFont} catch {font create TkMenuFont} variable F ;# miscellaneous platform-specific font parameters switch -- [tk windowingsystem] { win32 { if {$tcl_platform(osVersion) >= 5.0} { set F(family) "Tahoma" } else { set F(family) "MS Sans Serif" } set F(size) 8 font configure TkDefaultFont -family $F(family) -size $F(size) font configure TkTextFont -family $F(family) -size $F(size) font configure TkHeadingFont -family $F(family) -size $F(size) font configure TkCaptionFont -family $F(family) -size $F(size) \ -weight bold font configure TkTooltipFont -family $F(family) -size $F(size) font configure TkFixedFont -family Courier -size 10 font configure TkIconFont -family $F(family) -size $F(size) font configure TkMenuFont -family $F(family) -size $F(size) } aqua { set F(family) "Lucida Grande" set F(fixed) "Monaco" set F(menusize) 14 set F(size) 13 set F(viewsize) 12 set F(smallsize) 11 set F(fixedsize) 11 font configure TkDefaultFont -family $F(family) -size $F(size) font configure TkTextFont -family $F(family) -size $F(size) font configure TkHeadingFont -family $F(family) -size $F(smallsize) font configure TkCaptionFont -family $F(family) -size $F(size) \ -weight bold font configure TkTooltipFont -family $F(family) -size $F(smallsize) font configure TkFixedFont -family $F(fixed) -size $F(fixedsize) font configure TkIconFont -family $F(family) -size $F(size) font configure TkMenuFont -family $F(family) -size $F(menusize) } default - x11 { if {![catch {tk::pkgconfig get fontsystem} F(fs)] && $F(fs) eq "xft"} { set F(family) "sans-serif" set F(fixed) "monospace" } else { set F(family) "Helvetica" set F(fixed) "courier" } set F(size) -12 set F(ttsize) -10 set F(capsize) -14 set F(fixedsize) -12 font configure TkDefaultFont -family $F(family) -size $F(size) font configure TkTextFont -family $F(family) -size $F(size) font configure TkHeadingFont -family $F(family) -size $F(size) \ -weight bold font configure TkCaptionFont -family $F(family) -size $F(capsize) \ -weight bold font configure TkTooltipFont -family $F(family) -size $F(ttsize) font configure TkFixedFont -family $F(fixed) -size $F(fixedsize) font configure TkIconFont -family $F(family) -size $F(size) font configure TkMenuFont -family $F(family) -size $F(size) } } unset -nocomplain F ###} #*EOF* tcltk2/inst/tklibs/ttktheme_clearlooks/0000755000176200001440000000000014656355210017774 5ustar liggesuserstcltk2/inst/tklibs/ttktheme_clearlooks/create_imgs.py0000755000176200001440000003535214656355210022643 0ustar liggesusers#!/usr/bin/env python # -*- mode: python; coding: koi8-r; -*- import os import gtk, gobject imdir = 'images' imtype = 'png' background = '#efebe7' #fill_color = 0xff000000 # red fill_color = int('ff000000', 16) if not os.path.exists(imdir): os.mkdir(imdir) gc = None def draw_rect(): global gc if gc is None: gc = drawing_area.window.new_gc() colormap = gtk.gdk.colormap_get_system() gc.set_colormap(colormap) color = gtk.gdk.color_parse('red') colormap.alloc_color(color) gc.set_rgb_fg_color(color) drawing_area.window.draw_rectangle(gc, True, 0,0, 800,800) def save_image(fn, w, h, x=0, y=0): pixbuf = gtk.gdk.Pixbuf(gtk.gdk.COLORSPACE_RGB, True, 8, w, h) pixbuf.fill(fill_color) pb = pixbuf.get_from_drawable(drawing_area.window, drawing_area.get_colormap(), x,y, 0,0, w,h) pb.save(os.path.join(imdir, fn+"."+imtype), imtype) drawing_area.window.clear() draw_rect() done = False def save_callback(*args): global done if done: return done = True print 'create images' style = drawing_area.get_style() draw_rect() # separator w = 20 style.paint_vline(drawing_area.window, gtk.STATE_NORMAL, None, drawing_area, "frame", 0, w, 0) save_image('sep-v', 2, w) style.paint_hline(drawing_area.window, gtk.STATE_NORMAL, None, drawing_area, "frame", 0, w, 0) save_image('sep-h', w, 2) # tree w, h = 32, 32 w, h = 24, 24 for fn, state, shadow in ( ("tree-n", gtk.STATE_NORMAL, gtk.SHADOW_OUT), ("tree-h", gtk.STATE_PRELIGHT, gtk.SHADOW_OUT), ("tree-p", gtk.STATE_ACTIVE, gtk.SHADOW_IN), ("tree-d", gtk.STATE_INSENSITIVE, gtk.SHADOW_IN), ): style.paint_box(drawing_area.window, state, shadow, None, drawing_area, "stepper", 0,0, w,h) save_image(fn, w, h) # sizegrip w, h = 16, 16 fn = 'sizegrip' style.paint_resize_grip(drawing_area.window, gtk.STATE_NORMAL, None, drawing_area, "statusbar", gtk.gdk.WINDOW_EDGE_SOUTH_EAST, 0,0, w,h) save_image(fn, w, h) # progress w, h = 37+3, 16+3 progress_style = progress.get_style() fn = 'progress-h' progress_style.paint_box(drawing_area.window, gtk.STATE_PRELIGHT, gtk.SHADOW_NONE, None, progress, "bar", 0,0, w,h) save_image(fn, w, h) # button w, h = 32, 32 w, h = 28, 28 for fn, state, shadow in ( ("button-n", gtk.STATE_NORMAL, gtk.SHADOW_OUT), ("button-a", gtk.STATE_PRELIGHT, gtk.SHADOW_OUT), ("button-p", gtk.STATE_ACTIVE, gtk.SHADOW_IN), ("button-d", gtk.STATE_INSENSITIVE, gtk.SHADOW_OUT), ): style.paint_box(drawing_area.window, state, shadow, None, drawing_area, "buttondefault", 0,0, w,h) save_image(fn, w, h) style.paint_box(drawing_area.window, gtk.STATE_PRELIGHT, gtk.SHADOW_IN, None, togglebutton, "buttondefault", 0,0, w,h) save_image("button-pa", w, h) # toolbar w, h = 16, 16 w, h = 24, 24 fn = "blank" pixbuf = gtk.gdk.Pixbuf(gtk.gdk.COLORSPACE_RGB, True, 8, w, h) pixbuf.fill(fill_color) pixbuf.save(os.path.join(imdir, fn+"."+imtype), imtype) for fn, state, shadow in ( ("toolbutton-n", gtk.STATE_NORMAL, gtk.SHADOW_OUT), ("toolbutton-a", gtk.STATE_PRELIGHT, gtk.SHADOW_OUT), ("toolbutton-p", gtk.STATE_ACTIVE, gtk.SHADOW_IN), ("toolbutton-d", gtk.STATE_INSENSITIVE, gtk.SHADOW_IN), ): style.paint_box(drawing_area.window, state, shadow, None, drawing_area, "buttondefault", 0,0, w,h) save_image(fn, w, h) style.paint_box(drawing_area.window, gtk.STATE_PRELIGHT, gtk.SHADOW_IN, None, togglebutton, "buttondefault", 0,0, w,h) save_image("toolbutton-pa", w, h) # slider msl = hscroll.style_get_property("min_slider_length") msl = 20 sw = hscroll.style_get_property("slider_width") print '>>', msl, sw for t, w, h, state, orient in ( ('hn', msl,sw, gtk.STATE_NORMAL, gtk.ORIENTATION_HORIZONTAL), ('ha', msl,sw, gtk.STATE_PRELIGHT, gtk.ORIENTATION_HORIZONTAL), ('hp', msl,sw, gtk.STATE_NORMAL, gtk.ORIENTATION_HORIZONTAL), ('hd', msl,sw, gtk.STATE_INSENSITIVE, gtk.ORIENTATION_HORIZONTAL), ('vn', sw,msl, gtk.STATE_NORMAL, gtk.ORIENTATION_VERTICAL), ('va', sw,msl, gtk.STATE_PRELIGHT, gtk.ORIENTATION_VERTICAL), ('vp', sw,msl, gtk.STATE_NORMAL, gtk.ORIENTATION_VERTICAL), ('vd', sw,msl, gtk.STATE_INSENSITIVE, gtk.ORIENTATION_VERTICAL), ): fn = 'sbthumb-'+t if 0: style.paint_slider(drawing_area.window, state, gtk.SHADOW_OUT, None, drawing_area, "slider", 0,0, w,h, orient) else: if orient == gtk.ORIENTATION_VERTICAL: w, h = h, w style.paint_box(drawing_area.window, state, shadow, None, drawing_area, "stepper", 0,0, w,h) save_image(fn, w, h) msl = hscroll.style_get_property("min_slider_length") sw = hscroll.style_get_property("slider_width") # scale for t, w, h, state, orient in ( ('hn', msl,sw, gtk.STATE_NORMAL, gtk.ORIENTATION_HORIZONTAL), ('ha', msl,sw, gtk.STATE_PRELIGHT, gtk.ORIENTATION_HORIZONTAL), ('hd', msl,sw, gtk.STATE_INSENSITIVE, gtk.ORIENTATION_HORIZONTAL), ('vn', sw,msl, gtk.STATE_NORMAL, gtk.ORIENTATION_VERTICAL), ('va', sw,msl, gtk.STATE_PRELIGHT, gtk.ORIENTATION_VERTICAL), ('vd', sw,msl, gtk.STATE_INSENSITIVE, gtk.ORIENTATION_VERTICAL), ): fn = 'scale-'+t if orient == gtk.ORIENTATION_HORIZONTAL: detail = "hscale" else: detail = "vscale" style.paint_slider(drawing_area.window, state, gtk.SHADOW_OUT, None, drawing_area, detail, 0,0, w+2,h+2, orient) save_image(fn, w, h, 1, 1) w, h = msl, sw fn = 'scaletrough-h' style.paint_box(drawing_area.window, gtk.STATE_ACTIVE, gtk.SHADOW_IN, None, scale, "trough", 0,0, w,h) save_image(fn, w, h) # arrow w = h = hscroll.style_get_property("stepper_size") #w = h = 15 arrow_width = w / 2 arrow_height = h / 2 arrow_x = (w - arrow_width) / 2 arrow_y = (h - arrow_height) / 2 alloc = hscroll.get_allocation() x0 = alloc.x x1 = alloc.x+alloc.width-w alloc = vscroll.get_allocation() y0 = alloc.y y1 = alloc.y+alloc.height-h sn = gtk.STATE_NORMAL sp = gtk.STATE_PRELIGHT sa = gtk.STATE_ACTIVE si = gtk.STATE_INSENSITIVE for fn, x, y, state, shadow, arrow_type, widget in ( ("arrowleft-n", x0, 0, sn, gtk.SHADOW_OUT, gtk.ARROW_LEFT, hscroll), ("arrowleft-a", x0, 0, sp, gtk.SHADOW_OUT, gtk.ARROW_LEFT, hscroll), ("arrowleft-p", x0, 0, sa, gtk.SHADOW_IN, gtk.ARROW_LEFT, hscroll), ("arrowleft-d", x0, 0, si, gtk.SHADOW_OUT, gtk.ARROW_LEFT, hscroll), ("arrowright-n", x1, 0, sn, gtk.SHADOW_OUT, gtk.ARROW_RIGHT, hscroll), ("arrowright-a", x1, 0, sp, gtk.SHADOW_OUT, gtk.ARROW_RIGHT, hscroll), ("arrowright-p", x1, 0, sa, gtk.SHADOW_IN, gtk.ARROW_RIGHT, hscroll), ("arrowright-d", x1, 0, si, gtk.SHADOW_OUT, gtk.ARROW_RIGHT, hscroll), ("arrowup-n", 0, y0, sn, gtk.SHADOW_OUT, gtk.ARROW_UP, vscroll), ("arrowup-a", 0, y0, sp, gtk.SHADOW_OUT, gtk.ARROW_UP, vscroll), ("arrowup-p", 0, y0, sa, gtk.SHADOW_IN, gtk.ARROW_UP, vscroll), ("arrowup-d", 0, y0, si, gtk.SHADOW_OUT, gtk.ARROW_UP, vscroll), ("arrowdown-n", 0, y1, sn, gtk.SHADOW_OUT, gtk.ARROW_DOWN, vscroll), ("arrowdown-a", 0, y1, sp, gtk.SHADOW_OUT, gtk.ARROW_DOWN, vscroll), ("arrowdown-p", 0, y1, sa, gtk.SHADOW_IN, gtk.ARROW_DOWN, vscroll), ("arrowdown-d", 0, y1, si, gtk.SHADOW_OUT, gtk.ARROW_DOWN, vscroll), ): if 0: detail = 'hscrollbar' if widget is vscroll: detail = 'vscrollbar' else: x, y = 0, 0 detail = 'stepper' widget = drawing_area style.paint_box(drawing_area.window, state, shadow, None, widget, detail, x,y, w,h) style.paint_arrow(drawing_area.window, state, shadow, None, widget, detail, arrow_type, True, x+arrow_x, y+arrow_y, arrow_width, arrow_height) save_image(fn, w, h, x, y) # combobox w, h = w, 24 w, h = 16, 24 alloc = hscroll.get_allocation() x1 = alloc.x+alloc.width-w arrow_width = w / 2 arrow_height = h / 2 arrow_x = (w - arrow_width) / 2 arrow_y = (h - arrow_height) / 2 detail = 'hscrollbar' widget = hscroll for fn, state, shadow, arrow_type in ( ("comboarrow-n", gtk.STATE_NORMAL, gtk.SHADOW_OUT, gtk.ARROW_DOWN), ("comboarrow-a", gtk.STATE_PRELIGHT, gtk.SHADOW_OUT, gtk.ARROW_DOWN), ("comboarrow-p", gtk.STATE_ACTIVE, gtk.SHADOW_IN, gtk.ARROW_DOWN), ("comboarrow-d", gtk.STATE_INSENSITIVE, gtk.SHADOW_IN, gtk.ARROW_DOWN), ): style.paint_box(drawing_area.window, state, shadow, None, widget, detail, x1,0, w,h) style.paint_arrow(drawing_area.window, state, shadow, None, drawing_area, "stepper", arrow_type, True, x1+arrow_x, arrow_y, arrow_width, arrow_height) save_image(fn, w, h, x1, 0) w = 24 for fn, state, shadow in ( ("combo-rn", gtk.STATE_NORMAL, gtk.SHADOW_OUT), ("combo-ra", gtk.STATE_PRELIGHT, gtk.SHADOW_OUT), ("combo-rp", gtk.STATE_ACTIVE, gtk.SHADOW_IN), ("combo-rd", gtk.STATE_INSENSITIVE, gtk.SHADOW_OUT), ): style.paint_box(drawing_area.window, state, shadow, None, drawing_area, "button", 0,0, w+2,h) save_image(fn, w, h) style.paint_box(drawing_area.window, gtk.STATE_NORMAL, gtk.SHADOW_OUT, None, drawing_area, "button", 0,0, w+2,h) d = 3 style.paint_focus(drawing_area.window, gtk.STATE_NORMAL, None, drawing_area, "button", d,d, w-2*d,h-2*d) save_image('combo-rf', w, h) style.paint_shadow(drawing_area.window, gtk.STATE_NORMAL, gtk.SHADOW_IN, None, drawing_area, "entry", 0,0, w+2,h) save_image('combo-n', w, h) # checkbutton #define INDICATOR_SIZE 13 #define INDICATOR_SPACING 2 x, y = 2, 2 w, h = 13, 13 #w = h = checkbutton.style_get_property("indicator_size") for fn, state, shadow in ( ("check-nc", gtk.STATE_NORMAL, gtk.SHADOW_IN), ("check-nu", gtk.STATE_NORMAL, gtk.SHADOW_OUT), ("check-ac", gtk.STATE_PRELIGHT, gtk.SHADOW_IN), ("check-au", gtk.STATE_PRELIGHT, gtk.SHADOW_OUT), ("check-pc", gtk.STATE_ACTIVE, gtk.SHADOW_IN), ("check-pu", gtk.STATE_ACTIVE, gtk.SHADOW_OUT), ("check-dc", gtk.STATE_INSENSITIVE, gtk.SHADOW_IN), ("check-du", gtk.STATE_INSENSITIVE, gtk.SHADOW_OUT), ): ## style.paint_flat_box(drawing_area.window, ## gtk.STATE_PRELIGHT, ## gtk.SHADOW_ETCHED_OUT, ## gtk.gdk.Rectangle(0,0,w,h), drawing_area, ## "checkbutton", 0,0, w,h) style.paint_check(drawing_area.window, state, shadow, None, drawing_area, "checkbutton", x,y, w,h) save_image(fn, w+2*x, h+2*y) # radiobutton for fn, state, shadow in ( ("radio-nc", gtk.STATE_NORMAL, gtk.SHADOW_IN), ("radio-nu", gtk.STATE_NORMAL, gtk.SHADOW_OUT), ("radio-ac", gtk.STATE_PRELIGHT, gtk.SHADOW_IN), ("radio-au", gtk.STATE_PRELIGHT, gtk.SHADOW_OUT), ("radio-pc", gtk.STATE_ACTIVE, gtk.SHADOW_IN), ("radio-pu", gtk.STATE_ACTIVE, gtk.SHADOW_OUT), ("radio-dc", gtk.STATE_INSENSITIVE, gtk.SHADOW_IN), ("radio-du", gtk.STATE_INSENSITIVE, gtk.SHADOW_OUT), ): ## style.paint_flat_box(drawing_area.window, ## gtk.STATE_PRELIGHT, ## gtk.SHADOW_ETCHED_OUT, ## gtk.gdk.Rectangle(0,0,w,h), drawing_area, ## "checkbutton", 0,0, w,h) style.paint_option(drawing_area.window, state, shadow, None, drawing_area, "radiobutton", x,y, w,h) save_image(fn, w+2*x, h+2*y) # notebook w, h = 28, 22 state = gtk.STATE_NORMAL shadow = gtk.SHADOW_OUT for fn, gap_h, state in ( ("tab-n", 0, gtk.STATE_NORMAL), ("tab-a", 2, gtk.STATE_ACTIVE), ): ## style.paint_box_gap(drawing_area.window, state, shadow, ## gtk.gdk.Rectangle(0,0,w,gap_h), drawing_area, ## "notebook", 0,0, w,gap_h, gtk.POS_TOP, 0, w) y = gap_h hh = h - y style.paint_extension(drawing_area.window, state, gtk.SHADOW_OUT, None, drawing_area, "tab", 0,y, w,hh, gtk.POS_BOTTOM) save_image(fn, w, h+2) print 'done' gtk.main_quit() def pack(w, row, col): table.attach(w, col, col+1, row, row+1, gtk.EXPAND | gtk.FILL, gtk.EXPAND | gtk.FILL, 0, 0) win = gtk.Window() win.connect("destroy", gtk.main_quit) table = gtk.Table() win.add(table) row, col = 0, 0 drawing_area = gtk.DrawingArea() #drawing_area.set_size_request(100, 100) pack(drawing_area, row, col) row += 1 vscroll = gtk.VScrollbar() pack(vscroll, 0, 1) hscroll = gtk.HScrollbar() pack(hscroll, row, col) row += 1 notebook = gtk.Notebook() label = gtk.Label("Label") notebook.append_page(label) label = gtk.Label("Label") notebook.append_page(label) pack(notebook, row, col) row += 1 button = gtk.Button("Button") pack(button, row, col) row += 1 checkbutton = gtk.CheckButton("CheckButton") pack(checkbutton, row, col) row += 1 progress = gtk.ProgressBar() pack(progress, row, col) row += 1 scale = gtk.HScale() pack(scale, row, col) row += 1 entry = gtk.Entry() pack(entry, row, col) row += 1 togglebutton = gtk.ToggleButton() pack(togglebutton, row, col) togglebutton.set_active(True) row += 1 drawing_area.connect("expose-event", save_callback) #gobject.timeout_add(2000, save_callback) win.show_all() #drawing_area.modify_bg(gtk.STATE_NORMAL, gtk.gdk.color_parse('red')) gtk.main() tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks8.5.tcl0000644000176200001440000002615714656355210023104 0ustar liggesusers# clearlooks.tcl namespace eval ttk::theme::clearlooks { package provide ttk::theme::clearlooks 0.1 proc LoadImages {imgdir {patterns {*.gif}}} { foreach pattern $patterns { foreach file [glob -directory $imgdir $pattern] { set img [file tail [file rootname $file]] if {![info exists images($img)]} { set images($img) [image create photo -file $file] } } } return [array get images] } variable I array set I [LoadImages \ [file join [file dirname [info script]] clearlooks] *.gif] variable colors array set colors { -frame "#efebe7" -lighter "#f5f3f0" -dark "#cfcdc8" -darker "#9e9a9e" -darkest "#d4cfca" -selectbg "#7c99ad" -selectfg "#ffffff" -disabledfg "#b5b3ac" -entryfocus "#6f9dc6" -tabbg "#c9c1bc" -tabborder "#b5aca7" -troughcolor "#d7cbbe" -troughborder "#ae9e8e" -checklight "#f5f3f0" } ttk::style theme create clearlooks -parent clam -settings { ttk::style configure . \ -borderwidth 1 \ -background $colors(-frame) \ -foreground black \ -bordercolor $colors(-darkest) \ -darkcolor $colors(-dark) \ -lightcolor $colors(-lighter) \ -troughcolor $colors(-troughcolor) \ -selectforeground $colors(-selectfg) \ -selectbackground $colors(-selectbg) \ -font TkDefaultFont \ ; ttk::style map . \ -background [list disabled $colors(-frame) \ active $colors(-lighter)] \ -foreground [list disabled $colors(-disabledfg)] \ -selectbackground [list !focus $colors(-darker)] \ -selectforeground [list !focus white] \ ; # ttk::style configure Frame.border -relief groove ## Treeview. # ttk::style element create Treeheading.cell image \ [list $I(tree-n) \ selected $I(tree-p) \ disabled $I(tree-d) \ pressed $I(tree-p) \ active $I(tree-h) \ ] \ -border 4 -sticky ew #ttk::style configure Treeview -fieldbackground white ttk::style configure Row -background "#efefef" ttk::style map Row -background [list \ {focus selected} "#71869e" \ selected "#969286" \ alternate white] ttk::style map Item -foreground [list selected white] ttk::style map Cell -foreground [list selected white] ## Buttons. # ttk::style configure TButton -anchor center ttk::style configure TButton -padding {10 0} ttk::style layout TButton { Button.button -children { Button.focus -children { Button.padding -children { Button.label } } } } ttk::style element create button image \ [list $I(button-n) \ pressed $I(button-p) \ {selected active} $I(button-pa) \ selected $I(button-p) \ active $I(button-a) \ disabled $I(button-d) \ ] \ -border 4 -sticky ew ## Checkbuttons. # ttk::style element create Checkbutton.indicator image \ [list $I(check-nu) \ {disabled selected} $I(check-dc) \ disabled $I(check-du) \ {pressed selected} $I(check-pc) \ pressed $I(check-pu) \ {active selected} $I(check-ac) \ active $I(check-au) \ selected $I(check-nc) ] \ -width 24 -sticky w ttk::style map TCheckbutton -background [list active $colors(-checklight)] ttk::style configure TCheckbutton -padding 1 ## Radiobuttons. # ttk::style element create Radiobutton.indicator image \ [list $I(radio-nu) \ {disabled selected} $I(radio-dc) \ disabled $I(radio-du) \ {pressed selected} $I(radio-pc) \ pressed $I(radio-pu) \ {active selected} $I(radio-ac) \ active $I(radio-au) \ selected $I(radio-nc) ] \ -width 24 -sticky w ttk::style map TRadiobutton -background [list active $colors(-checklight)] ttk::style configure TRadiobutton -padding 1 ## Menubuttons. # #ttk::style configure TMenubutton -relief raised -padding {10 2} # ttk::style element create Menubutton.border image $I(toolbutton-n) \ # -map [list \ # pressed $I(toolbutton-p) \ # selected $I(toolbutton-p) \ # active $I(toolbutton-a) \ # disabled $I(toolbutton-n)] \ # -border {4 7 4 7} -sticky nsew ttk::style element create Menubutton.border image \ [list $I(button-n) \ selected $I(button-p) \ disabled $I(button-d) \ active $I(button-a) \ ] \ -border 4 -sticky ew ## Toolbar buttons. # ttk::style configure Toolbutton -padding -5 -relief flat ttk::style configure Toolbutton.label -padding 0 -relief flat ttk::style element create Toolbutton.border image \ [list $I(blank) \ pressed $I(toolbutton-p) \ {selected active} $I(toolbutton-pa) \ selected $I(toolbutton-p) \ active $I(toolbutton-a) \ disabled $I(blank)] \ -border 11 -sticky nsew ## Entry widgets. # ttk::style configure TEntry -padding 1 -insertwidth 1 \ -fieldbackground white ttk::style map TEntry \ -fieldbackground [list readonly $colors(-frame)] \ -bordercolor [list focus $colors(-selectbg)] \ -lightcolor [list focus $colors(-entryfocus)] \ -darkcolor [list focus $colors(-entryfocus)] \ ; ## Combobox. # ttk::style configure TCombobox -selectbackground ttk::style element create Combobox.downarrow image \ [list $I(comboarrow-n) \ disabled $I(comboarrow-d) \ pressed $I(comboarrow-p) \ active $I(comboarrow-a) \ ] \ -border 1 -sticky {} ttk::style element create Combobox.field image \ [list $I(combo-n) \ {readonly disabled} $I(combo-rd) \ {readonly pressed} $I(combo-rp) \ {readonly focus} $I(combo-rf) \ readonly $I(combo-rn) \ ] \ -border 4 -sticky ew ## Notebooks. # # ttk::style element create tab image $I(tab-a) -border {2 2 2 0} \ # -map [list selected $I(tab-n)] ttk::style configure TNotebook.Tab -padding {6 2 6 2} ttk::style map TNotebook.Tab \ -padding [list selected {6 4 6 2}] \ -background [list selected $colors(-frame) {} $colors(-tabbg)] \ -lightcolor [list selected $colors(-lighter) {} $colors(-dark)] \ -bordercolor [list selected $colors(-darkest) {} $colors(-tabborder)] \ ; ## Labelframes. # ttk::style configure TLabelframe -borderwidth 2 -relief groove ## Scrollbars. # ttk::style layout Vertical.TScrollbar { Scrollbar.trough -sticky ns -children { Scrollbar.uparrow -side top Scrollbar.downarrow -side bottom Vertical.Scrollbar.thumb -side top -expand true -sticky ns } } ttk::style layout Horizontal.TScrollbar { Scrollbar.trough -sticky we -children { Scrollbar.leftarrow -side left Scrollbar.rightarrow -side right Horizontal.Scrollbar.thumb -side left -expand true -sticky we } } ttk::style element create Horizontal.Scrollbar.thumb image \ [list $I(sbthumb-hn) \ disabled $I(sbthumb-hd) \ pressed $I(sbthumb-ha) \ active $I(sbthumb-ha)] \ -border 3 ttk::style element create Vertical.Scrollbar.thumb image \ [list $I(sbthumb-vn) \ disabled $I(sbthumb-vd) \ pressed $I(sbthumb-va) \ active $I(sbthumb-va)] \ -border 3 foreach dir {up down left right} { ttk::style element create ${dir}arrow image \ [list $I(arrow${dir}-n) \ disabled $I(arrow${dir}-d) \ pressed $I(arrow${dir}-p) \ active $I(arrow${dir}-a)] \ -border 1 -sticky {} } ttk::style configure TScrollbar -bordercolor $colors(-troughborder) ## Scales. # ttk::style element create Scale.slider image \ [list $I(scale-hn) \ disabled $I(scale-hd) \ active $I(scale-ha) \ ] ttk::style element create Scale.trough image $I(scaletrough-h) \ -border 2 -sticky ew -padding 0 ttk::style element create Vertical.Scale.slider image \ [list $I(scale-vn) \ disabled $I(scale-vd) \ active $I(scale-va) \ ] ttk::style element create Vertical.Scale.trough image $I(scaletrough-v) \ -border 2 -sticky ns -padding 0 ttk::style configure TScale -bordercolor $colors(-troughborder) ## Progressbar. # ttk::style element create Horizontal.Progressbar.pbar image $I(progress-h) \ -border {2 2 1 1} ttk::style element create Vertical.Progressbar.pbar image $I(progress-v) \ -border {2 2 1 1} ttk::style configure TProgressbar -bordercolor $colors(-troughborder) ## Statusbar parts. # ttk::style element create sizegrip image $I(sizegrip) ## Paned window parts. # # ttk::style element create hsash image $I(hseparator-n) -border {2 0} \ # -map [list {active !disabled} $I(hseparator-a)] # ttk::style element create vsash image $I(vseparator-n) -border {0 2} \ # -map [list {active !disabled} $I(vseparator-a)] ttk::style configure Sash -sashthickness 6 -gripcount 16 ## Separator. # #ttk::style element create separator image $I(sep-h) #ttk::style element create hseparator image $I(sep-h) #ttk::style element create vseparator image $I(sep-v) } } tcltk2/inst/tklibs/ttktheme_clearlooks/readme.txt0000644000176200001440000000017314656355210021773 0ustar liggesusersclearlook ttk theme borrowed from PySolFC (GNU General Public License 3.0) (see http://sourceforge.net/projects/pysolfc/). tcltk2/inst/tklibs/ttktheme_clearlooks/pkgIndex.tcl0000644000176200001440000000063614656355210022256 0ustar liggesusers# Package index for tile demo pixmap themes. if {[file isdirectory [file join $dir clearlooks]]} { if {[package vsatisfies [package require tile] 0.8.0]} { package ifneeded ttk::theme::clearlooks 0.1 \ [list source [file join $dir clearlooks8.5.tcl]] } else { package ifneeded tile::theme::clearlooks 0.1 \ [list source [file join $dir clearlooks8.4.tcl]] } } tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks8.4.tcl0000644000176200001440000002543214656355210023076 0ustar liggesusers# clearlooks.tcl namespace eval tile::theme::clearlooks { package provide tile::theme::clearlooks 0.1 variable I array set I [tile::LoadImages \ [file join [file dirname [info script]] clearlooks] *.gif] variable colors array set colors { -frame "#efebe7" -lighter "#f5f3f0" -dark "#cfcdc8" -darker "#9e9a9e" -darkest "#d4cfca" -selectbg "#7c99ad" -selectfg "#ffffff" -disabledfg "#b5b3ac" -entryfocus "#6f9dc6" -tabbg "#c9c1bc" -tabborder "#b5aca7" -troughcolor "#d7cbbe" -troughborder "#ae9e8e" -checklight "#f5f3f0" } style theme create clearlooks -parent clam -settings { style configure . \ -borderwidth 1 \ -background $colors(-frame) \ -foreground black \ -bordercolor $colors(-darkest) \ -darkcolor $colors(-dark) \ -lightcolor $colors(-lighter) \ -troughcolor $colors(-troughcolor) \ -selectforeground $colors(-selectfg) \ -selectbackground $colors(-selectbg) \ -font TkDefaultFont \ ; style map . \ -background [list disabled $colors(-frame) \ active $colors(-lighter)] \ -foreground [list disabled $colors(-disabledfg)] \ -selectbackground [list !focus $colors(-darker)] \ -selectforeground [list !focus white] \ ; # style configure Frame.border -relief groove ## Treeview. # style element create Treeheading.cell image $I(tree-n) \ -map [list \ selected $I(tree-p) \ disabled $I(tree-d) \ pressed $I(tree-p) \ active $I(tree-h) \ ] \ -border 4 -sticky ew #style configure Treeview -fieldbackground white style configure Row -background "#efefef" style map Row -background [list \ {focus selected} "#71869e" \ selected "#969286" \ alternate white] style map Item -foreground [list selected white] style map Cell -foreground [list selected white] ## Buttons. # #style configure TButton -padding {10 0} -anchor center style configure TButton -padding {5 5} -anchor center -width -9 style layout TButton { Button.button -children { Button.focus -children { Button.padding -children { Button.label } } } } style element create button image $I(button-n) \ -map [list \ pressed $I(button-p) \ {selected active} $I(button-pa) \ selected $I(button-p) \ active $I(button-a) \ disabled $I(button-d) \ ] \ -border 4 -sticky ew ## Checkbuttons. # style element create Checkbutton.indicator image $I(check-nu) \ -width 24 -sticky w -map [list \ {disabled selected} $I(check-dc) \ disabled $I(check-du) \ {pressed selected} $I(check-pc) \ pressed $I(check-pu) \ {active selected} $I(check-ac) \ active $I(check-au) \ selected $I(check-nc) ] style map TCheckbutton -background [list active $colors(-checklight)] style configure TCheckbutton -padding 1 ## Radiobuttons. # style element create Radiobutton.indicator image $I(radio-nu) \ -width 24 -sticky w \ -map [list \ {disabled selected} $I(radio-dc) \ disabled $I(radio-du) \ {pressed selected} $I(radio-pc) \ pressed $I(radio-pu) \ {active selected} $I(radio-ac) \ active $I(radio-au) \ selected $I(radio-nc) ] style map TRadiobutton -background [list active $colors(-checklight)] style configure TRadiobutton -padding 1 ## Menubuttons. # #style configure TMenubutton -relief raised -padding {10 2} # style element create Menubutton.border image $I(toolbutton-n) \ # -map [list \ # pressed $I(toolbutton-p) \ # selected $I(toolbutton-p) \ # active $I(toolbutton-a) \ # disabled $I(toolbutton-n)] \ # -border {4 7 4 7} -sticky nsew style element create Menubutton.border image $I(button-n) \ -map [list \ selected $I(button-p) \ disabled $I(button-d) \ active $I(button-a) \ ] \ -border 4 -sticky ew ## Toolbar buttons. # style configure Toolbutton -padding -5 -relief flat style configure Toolbutton.label -padding 0 -relief flat style element create Toolbutton.border image $I(blank) \ -map [list \ pressed $I(toolbutton-p) \ {selected active} $I(toolbutton-pa) \ selected $I(toolbutton-p) \ active $I(toolbutton-a) \ disabled $I(blank)] \ -border 11 -sticky nsew ## Entry widgets. # style configure TEntry -padding 1 -insertwidth 1 \ -fieldbackground white style map TEntry \ -fieldbackground [list readonly $colors(-frame)] \ -bordercolor [list focus $colors(-selectbg)] \ -lightcolor [list focus $colors(-entryfocus)] \ -darkcolor [list focus $colors(-entryfocus)] \ ; ## Combobox. # style configure TCombobox -selectbackground style element create Combobox.downarrow image $I(comboarrow-n) \ -map [list \ disabled $I(comboarrow-d) \ pressed $I(comboarrow-p) \ active $I(comboarrow-a) \ ] \ -border 1 -sticky {} style element create Combobox.field image $I(combo-n) \ -map [list \ {readonly disabled} $I(combo-rd) \ {readonly pressed} $I(combo-rp) \ {readonly focus} $I(combo-rf) \ readonly $I(combo-rn) ] \ -border 4 -sticky ew ## Notebooks. # # style element create tab image $I(tab-a) -border {2 2 2 0} \ # -map [list selected $I(tab-n)] style configure TNotebook.Tab -padding {6 2 6 2} style map TNotebook.Tab \ -padding [list selected {6 4 6 2}] \ -background [list selected $colors(-frame) {} $colors(-tabbg)] \ -lightcolor [list selected $colors(-lighter) {} $colors(-dark)] \ -bordercolor [list selected $colors(-darkest) {} $colors(-tabborder)] \ ; ## Labelframes. # style configure TLabelframe -borderwidth 2 -relief groove ## Scrollbars. # style layout Vertical.TScrollbar { Scrollbar.trough -sticky ns -children { Scrollbar.uparrow -side top Scrollbar.downarrow -side bottom Vertical.Scrollbar.thumb -side top -expand true -sticky ns } } style layout Horizontal.TScrollbar { Scrollbar.trough -sticky we -children { Scrollbar.leftarrow -side left Scrollbar.rightarrow -side right Horizontal.Scrollbar.thumb -side left -expand true -sticky we } } style element create Horizontal.Scrollbar.thumb image $I(sbthumb-hn) \ -map [list \ disabled $I(sbthumb-hd) \ pressed $I(sbthumb-ha) \ active $I(sbthumb-ha)] \ -border 3 style element create Vertical.Scrollbar.thumb image $I(sbthumb-vn) \ -map [list \ disabled $I(sbthumb-vd) \ pressed $I(sbthumb-va) \ active $I(sbthumb-va)] \ -border 3 foreach dir {up down left right} { style element create ${dir}arrow image $I(arrow${dir}-n) \ -map [list \ disabled $I(arrow${dir}-d) \ pressed $I(arrow${dir}-p) \ active $I(arrow${dir}-a)] \ -border 1 -sticky {} } style configure TScrollbar -bordercolor $colors(-troughborder) ## Scales. # style element create Scale.slider image $I(scale-hn) \ -map [list \ disabled $I(scale-hd) \ active $I(scale-ha) \ ] style element create Scale.trough image $I(scaletrough-h) \ -border 2 -sticky ew -padding 0 style element create Vertical.Scale.slider image $I(scale-vn) \ -map [list \ disabled $I(scale-vd) \ active $I(scale-va) \ ] style element create Vertical.Scale.trough image $I(scaletrough-v) \ -border 2 -sticky ns -padding 0 style configure TScale -bordercolor $colors(-troughborder) ## Progressbar. # style element create Horizontal.Progressbar.pbar image $I(progress-h) \ -border {2 2 1 1} style element create Vertical.Progressbar.pbar image $I(progress-v) \ -border {2 2 1 1} style configure TProgressbar -bordercolor $colors(-troughborder) ## Statusbar parts. # style element create sizegrip image $I(sizegrip) ## Paned window parts. # # style element create hsash image $I(hseparator-n) -border {2 0} \ # -map [list {active !disabled} $I(hseparator-a)] # style element create vsash image $I(vseparator-n) -border {0 2} \ # -map [list {active !disabled} $I(vseparator-a)] style configure Sash -sashthickness 6 -gripcount 16 ## Separator. # #style element create separator image $I(sep-h) #style element create hseparator image $I(sep-h) #style element create vseparator image $I(sep-v) } } tcltk2/inst/tklibs/ttktheme_clearlooks/convert_imgs.sh0000755000176200001440000000075514656355210023041 0ustar liggesusers#!/bin/sh from_dir=images to_dir=clearlooks # transpose for t in $from_dir/sbthumb-v*.png; do echo transpose $t mv -f $t tmp.png convert tmp.png -transpose $t rm -f tmp.png done for t in progress scaletrough; do echo transpose $t convert $from_dir/$t-h.png -transpose $from_dir/$t-v.png done # convert to gif for f in $from_dir/*.png; do t=`basename $f .png` echo convert $t pngtopnm images/$t.png | ppmtogif -transparent==red > $to_dir/$t.gif done tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/0000755000176200001440000000000014656355210022132 5ustar liggesuserstcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/button-p.gif0000644000176200001440000000100714656355210024367 0ustar liggesusersGIF87aÄÆõïëçÖÏÎÖËÎÎÏÆÎËÆÎÇÆÎÃÆƾ½ÖÏÆÖËÆÖÇÆsqksmksikkmckickecξ½{qk{mksqcsmcsicsecƶ­Æ˽ÆǽÆýÎ˽ÎǽÎý,þ`àEdižhé‰Qæ¾p,¿‘eD’! ‰ž/×+òxLFAP™Ìœ"xœ6¡ÌíX5ö¢ÌïqÌ Eá«N_yh8Z¹š„‚^]ÔçïjMh7mƒjzˆ‡ƒ{„Šz ‰—’‰‘ z¡™’¢’£  ”¡¬°”´“™³¶½¶´¹ ½¹°„‘³³ÁÌÁ¾·ÍÅÅ×ÍÜÚËÉÚÛÙàÅÚÚèåà ÖóôàöÚøóàüÕöl8pÀCAƒ ¸ûwàÿ€Ï!È!ãE»‚ΈHqà9ƒr¼pHðšÁþ 92G $ ŠD0ƒ%—WŽü—à 4D~ÌI#d¶O4~¾üP¥Êœ@WæT0'‘5@âiUªTi\Õú¨U9Z´ ñÔ©W³X–Õº°Å!@„Qƒn]¹uãÖÀ‹wnŽàÚqãFÃ!D¶‘8„ Äç À‚Ž8Dh¾,"3ŽËœ=ÆœCA9rŒ¸Ü u9Zp½ºµêÔ$¸à€·Ž½uøîÍ»·ÄäHð ‚ëçУGðà@óسkßÎ{õ ;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/tab-n.gif0000644000176200001440000000104514656355210023622 0ustar liggesusersGIF89aÕÿó÷÷÷ï÷óï÷ïï÷ëïïóçïïçïë眒{œŠ{”ŠsœŽ„œŠ„„ysŒ}sŒys„}k„yk„ukÿ„¢µ„‚sÿÿÿ÷ó÷ï÷ïïóïïïïïë{”†{”‚{Œ†sŒ‚sçÛÖÆÃÆRekRakA!ù,þÀ‰ˆD,È¢HH¢8ŸÐ¨ôI¦ØìSb¹.€¯8 {½ßsH±ŒÏg1:E]à²ìÿi_}|{vm_z„ŠŽˆ|!”‹‹œ–¢‹¢„š§›š«£™¢z§ž¶‹¸z!¥¼¸¶Æŧ¼Å£ ¦ÆÄÇÓ·ÉǵÅ! ™ØÓÅÇÍÒÚ!Çáïïðâáïô!ýÇþâë÷¯Ÿ†ùöÙ3p!A‚þ\h „ü0@`ãF z$àcE ¨l¨r£J“/[: Á!¿qØ°3äC&y‘€ž0yò< ©La†X€à&Ô§Lu`ºõ*Ô¬!,°õëϲ^±b…:u‚Û·pãÊK·®Ý A;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/arrowleft-a.gif0000644000176200001440000000037014656355210025044 0ustar liggesusersGIF87aÄ÷ûï÷÷ï÷óï÷ïïïóçïïçïëçïçç„uk{ukçëÞççÞÿÿÿ{ucÿûÿÿ÷ÿ÷ÿ÷÷û÷÷÷÷÷ó÷ï÷ïïóïïïïïëïçÛÖÿû÷ÿ÷÷,}`ƒŒdI&£®ìŠ$Œæ@³#;8&Æ‘öôÀHób6’ÈÙ(‡(ÆDB d2Tª.% L(×ÌDð%„A8ST*˜ha`)„郱Á0.W~D) ‹‚Œq| ’’‰“q) ›œf ¤¥¦¤"&ª$!;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/tab-a.gif0000644000176200001440000000103014656355210023577 0ustar liggesusersGIF89aÕÞßÖÞÛÖÞ×ÖÞÓÖÖÛÎÖ×ÎÖÓÎÖÏÎÎÓÆÞÛÎÞ×ÎÞÓÎÞÏÎÖÓÆÖÏÆsqksmksikkmckickecÿ{qk{mksqcsmcsicsecçßÞçÛÞÿÿÿÞßÞÞÛÞÎǽA!ù,þÀŠpH,ȤR¢8ŸÐ¨ôª4=جvËÍRB€ÉhÀGþ¤9“§£^Ó?k< C¿ïËxae „te‡ ‡……a‡t…‡š–Ž{š†›¦Ž›¨šªš¥š³¦¦µ´›¤²¹³Ã¿²Å³¯ ĵÂȴͲÃÓ¾ÚÚ ÂÛÜÂÞÙßßêíìïîîéù÷öíüèåK—nÁ?}`ð_sì`€bÅ‹ÿ14ð¯b  pYÀÀ’KŠŒ¸ÒÀ¼"EžŒIS¦M›.x8` 6ƒžŸ£t$ˆ(‰‡‰‰‰$ššš˜ ›¦§˜¦/¥¥¦/..$/#¼¼«·  %ÇÇ0ºµÃ ÎÅÐÅ,$ 01½¼× µÕ!1!ÈÇ á,+$!!2ëíáì-é2 !Ú#2õ+é"úãJˆH ‚ $$˜1caC…3 "d8!‚… f\”H‚BÆf„T`!E hPX¹ %…,D€@¢… -mÂÄY’f,Î 8 µæÐ €Z``ÁšM“6eJ•hƒQ³f}ЀÃÕ`Êí;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/arrowleft-p.gif0000644000176200001440000000037314656355210025066 0ustar liggesusersGIF87aÄÞÛÖÞ×ÖÞÓÖÖÛÎÖ×ÎÖÓÎÖÏÎÖËÎÎÓÆÎÏÆÎËÆÎÇÆÎÃÆkiZÞÛÎÞ×ÎÞÓÎÖÓÆÖÏÆÖËÆkickecsecƶ­ÆǽçÛÖÎ˽ÎǽÎý,€ cdIV¦®ìz¥@ ¸æ\˜PàŸ¯Ñ 0…A!Y(•F^Ä@5Uƒ.eWÀÁð5¦ŠCVL¢E¡#äÍÅY,(~W ~#  ƒŠ‰F|  “•pžŸ z)§¨©§;&­$!;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/combo-ra.gif0000644000176200001440000000101714656355210024317 0ustar liggesusersGIF87aÕ÷ûï÷÷ï÷óï÷ïïïóçïïçïëçïççïã眒{œŠ{ÖÓÎÎËÆœ’„œŽ„œŠ„„ysŒ}s„}k„yk„uk{uk„‚sçëÞççÞçãÞÿÿÿÿûÿÿ÷ÿ÷ÿ÷÷û÷÷÷÷÷ó÷ï÷ïïóïïïïçï甊{”†{”‚{Œ†sŒ‚sïçÞçãÖçÛÖÿÿ÷ÿû÷ÿ÷÷A,þ@ƒB,HÊPÃl:ŸPM%J¥R4›ÎfƒÕ¶:Øn–ÛÚN4ž'V»=.¸Û¥†h8ë8Î÷¼^xzg~‰//‹ˆ‹~  ˜—‰™™œœ˜!› !«®œª© ¶©¶¼­½¥ "ª"ªÃɼÉ")ÊÃŶÊÒѶ'Ï"ÃÝÚÛÅÛß(äÚÚÛ"ÞÚðä&Ï#Þ#ßä#ìùìôðQ€€½nÞâ3èmD H71bÅ|x8°#ÁŠ%v,0q„ $ ¨\i Ë”*]®| áÀ… 6qêÌyÀÀ5Í=q&ЀG1(5Š)Ó¥JhÈ@µªÕ«VWP]Ѐ…ׯ`Êea€kƒ³hÓª];tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/button-pa.gif0000644000176200001440000000061214656355210024531 0ustar liggesusersGIF87aÄïë眒{œŽ{œŠ{œ†{ÞÛÖÖÓÎÎËÆÖ˽œ’„œŽ„„}sœŠ„„ys„usÞÛΔ}{Œ}sŒys„}k„yk„uk{uk”Ž{”Š{”†{”‚{ŒŠsŒ†sŒ‚sçÛÖ,þ pTdižhyˆâ¾p,¿Õa!Eñè^áõ½GÏ',Ip¸ÓùˆÊœÔç©PBÞÒØ„B…G2ÜyÊòðG¹j¥ê\3›ý5&ÉzÑ ›Õ&qP(( 9¯øhä– ³î·+þ®ÙboºãŽÃÛêî%sï]€]ƒp‚Š‚Š{ŒŠ““ŒšŽšˆ“˜£Œ¥¢¯¥¦Œ£‰££ºÀ»º ¬¿»Êʼ˼ÆʻֿØÕ¿Ê·ÌÛàÌáæèäñðàÛõøÆóùôñòŃç… ÿÒÓ·^Bï$0œ(Q"‡Šú,NxÇãÄ\40 DÀJ‰,%ˆ4 É 8sêÜÉ3;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/button-d.gif0000644000176200001440000000111614656355210024354 0ustar liggesusersGIF87aÕÿó÷÷÷ï÷óï÷ïï÷ëïïóçïïçïëçïççÞßÖÞÛÖÞÛÎçëÞççÞçãÞçßÞçÛÞƶ­ÿÿÿ÷û÷÷÷÷÷ó÷ïóïïïïïëïçëçïëÞïçÞïãÞïßÞçãÖçßÖçÛÖç×Öÿ÷÷A,þÀ(B,È"H‘8ŸÐ¨ôJ(”IVDq¹n7Læ›”€U§±ë@Å Çž%r\>ïç}€{w†€‡†Œ‹…†w•”–™”—•šw¡¡¤¤££¢§ŸD³³·¸´ºµ´wÅõɸ˺ÉwÈÃÒÆÖËÃÎËÂØÝÞßÞÜÝäàËæÛ±Ë Ýì ìîíØÜïôôÞñòØÝpƒîØ!Txg^B "Øï¡B±6$4¨qB6€œÈ áD!jtèNcƒ„¼”‰`æš7_†´yç¥tË?k¦Äy_, 8à°”iR¦H9<}ªôŽƒwòjà…dÈ ”©Ó¦ ,=õ„4 ÐЂ«†¯[t öŃ6¨]˶-[f8xA·®Ý»w00 ×ß¿€Þ;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/check-pu.gif0000644000176200001440000000014014656355210024313 0ustar liggesusersGIF89a‘­žŒÖÏÎÖËÆÿ!ù,1œ©Ëà¢Ú+À¡û¯ÔG¡1–Þ9¤ª¹½ëª4'ß2,⯞›D†,†ñ˜(;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/tree-n.gif0000644000176200001440000000102014656355210024004 0ustar liggesusersGIF87aÕÿó÷÷÷ï÷óï÷ïï÷ëïïóçïïçïëçïççïãçÞãÖÞßÖ„uk{ukçëÞççÞçãÞçßÞçÛÞÿÿÿ{uc÷÷÷÷ó÷÷ï÷ï÷ïïóïïïïïëïïëÞïçÞïãÞïßÞçãÖçßÖçÛÖA,þ@ cH,ĉrÉl:'ƤR TT¬¥J­–€H8 [Ìà€3¤‹gx³`̘\ðx€x"C‹ˆ††‹•†Rœ ŸŸž‡}ªª°°«°" µ°¼¬¬°¼¨ÆÄ˾ÏÃÄcºÑØÙ×ÑÉàãÖá×èšçãïãäöñÉñ  ôoÀnd ᇀ#2|À.BИñ¢ÃŒÔ&l „%7~H¹D2PÆ< SfÍ&#$‹B6OŸ0Cà¢gÌìH(º€i JCD]ª4™ˆ¦"®J!é‚«`Á:ÊJ¶¬Ù³¸„ Y‹$;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/sep-h.gif0000644000176200001440000000005014656355210023630 0ustar liggesusersGIF87a€ÞÓÎÿûÿ,„™Áíÿ ;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/arrowright-n.gif0000644000176200001440000000037414656355210025250 0ustar liggesusersGIF87aÄÿó÷÷÷ï÷óï÷ïï÷ëïïóçïïçïëçïççïãçÞßÖ„uk{ukçëÞççÞçãÞçßÞÿÿÿ{uc÷÷÷÷ó÷ïóïïïïïëïïçÞïãÞçãÖçßÖçÛÖ, ´ŒdI2K¤®ìº0Q@SÈEqb$ü”Ÿ°"à¼"…A¥ÒI*•Td`± :ƒÕÊK ¶s9 FØ¡8Œ;‡x4ÅF`ƈ<Â(‰` XF)ŒŒŠQ}”‹—s    ¢i¨©ª¨"&®$!;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/sizegrip.gif0000644000176200001440000000011514656355210024452 0ustar liggesusersGIF87a‘ïëçƶ­ÿÿÿ,&„©{Â*ÂCq6iAÕsïåa öA$ia²j¢zÂlìªrWíZ;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/arrowup-d.gif0000644000176200001440000000034414656355210024542 0ustar liggesusersGIF87aÄÿó÷÷÷ï÷óï÷ïï÷ëïïóçïïçïëçïççïãçÞßÖµ²­çëÞççÞçãÞçßÞƶ­ÿÿÿ÷÷÷÷ó÷ïóïïïïïëïïçÞïãÞçãÖçßÖçÛÖ,i $Žd Ehª¦bL/0M[+ìÓîS‚Ü©0 PÄbQT*ÃÂ…2‹t±°†+Á-ÎÌqy@0/Ä Õ`bŽ{>gfx‚L  ŠŠŒL‘’“‘&–#!;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/progress-h.gif0000644000176200001440000000043114656355210024710 0ustar liggesusersGIF87a(³­¾Î{ž­{š­{–­{’­sš¥s–¥s’¥{š¥{–¥{’¥„¢µ„žµ„šµ„ž­Rak,(ÎðÉI«½¸‚Í»ÿ`¸I€Ã'c2Këº&Š®oíi³µÛ仞A 4F£°…L&ËE“t¡K£5°Å µ ’ )ˆrÇãªY€[ËË·¼ÎîzoÀðûQ~l$|ƒ‡l‰~…Qƒ‰|‘•”””Ÿž ‰£$K   Qª¬® ¨=«ª·Q¶¸º.´/·¹¹ ¹QúƻÀœ5ÄÄÌBÐÒ¿/Á ÝÞÞÈÝßã=ÁèééQêíBðññ;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/scaletrough-h.gif0000644000176200001440000000012714656355210025366 0ustar liggesusersGIF89a‘­žŒÖ˽ÿƶ­!ù,(”©Ëí£œT‚‹³Þ†âH^C€¦êʲf ÇiG×Y…çúÎ÷N;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/comboarrow-n.gif0000644000176200001440000000070314656355210025226 0ustar liggesusersGIF89aÕÿó÷÷÷ï÷óï÷ïï÷ëïïóçïïçïëçïççïãçÞãÖÞßÖÎËÆ„ukÿ{ukçëÞççÞçãÞçßÞçÛÞÿÿÿ{uc÷÷÷÷ó÷ï÷ïïóïïïïïëïïçÞïãÞïßÞçãÖçßÖçÛÖA!ù,àÀ†pH$2ŠrÉ\6É ær LÖÀEÔH¾ x,²4*a1F°¶f0ܳ@#˜ÏtÁ@ôk€zƒq€‡Š{f“––\“” |g#¨©#”£B¦ª#¦¦…±¨··|I½½#ÁÁ…Í ÍÍ|›ÕÐØ×…×ÝààÈ]à æé¤  ñöõ\I !òò þ…(s&… .8˜p¦ "DPˆ(q ƒú RܸñI‘CŽ;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/check-pc.gif0000644000176200001440000000051414656355210024276 0ustar liggesusersGIF89aÕ­žŒc]Z)$!ÖÏÎÎËÆÎÇÆRURJMJJIJBABÖÏÆÖËÆ{ys{us¥žœkicÿŒŠŒ½ºµ”’Œ”ŽŒÆýŒŠ„989),) „}{A!ù,i@‰pH,È€rÉ\¨tÚ<„¬Ö @¬C¨6kÈ, ß«á’e$8”,XÕt> à¡K  hrWc~b Œq}‰ ciaXY‘ —aMª~H­®EA;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/sbthumb-hp.gif0000644000176200001440000000042614656355210024674 0ustar liggesusersGIF87aÄÿó÷÷÷ï÷óï÷ïï÷ëïïóçïïçïëçïççïãçÞßÖ„uk{ukçëÞççÞçãÞçßÞÿÿÿ{uc÷÷÷÷ó÷ïóïïïïïëïïçÞïãÞçãÖçßÖçÛÖ,› ´ŒdišQª®¬º0Q@SÈ5Ë2'F‚ %H¬) ç) *•óI9ŒEd`± _¯üÅj†‹áÀ¾{탈C>ÏîëKZxƒˆxxK ’“– ŸŸ£ž¨ž«©ªf  ··¹¹¶X0ÂÃÄÅÂ'ÈÉ!;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/sep-v.gif0000644000176200001440000000005014656355210023646 0ustar liggesusersGIF87a€ÞÓÎÿûÿ,DŒ§Éë ;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/toolbutton-pa.gif0000644000176200001440000000051514656355210025431 0ustar liggesusersGIF87aÄïë眒{œŠ{”‚sÞÛÖÖÓÎÎËÆÖ˽œ’„œŽ„œŠ„„ysÞÛÎŒ}sŒys„}k„yk„uk{uk„‚s{uc”Š{”†{”‚{Œ†sŒ‚sçÛÖ,Ò `Ddiž§!FGë¾0ÒA ®Ú¾3;Hai€ÁŽ'<ÞxȨC·£²8}9ŸNÛ„H«OpòFÕ8Þöpé#é7ÌÓRÿ^BLXO…>xqLW~dNzMY:YJ=6s~†rZ^`L…Wšœ6c‰©_}®AlU«?:zZb†™›¾lN|9O@S²Mj‰ „€TtÈ> •daVv= Ÿ—=ÜhZ Äòóòðúûüýü÷!;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/arrowup-n.gif0000644000176200001440000000037014656355210024553 0ustar liggesusersGIF87aÄÿó÷÷÷ï÷óï÷ïï÷ëïïóçïïçïëçïççïãçÞßÖ„uk{ukçëÞççÞçãÞçßÞÿÿÿ{uc÷÷÷÷ó÷ïóïïïïïëïïçÞïãÞçãÖçßÖçÛÖ,} ´ŒdI2K¤®ìº0Q@SÈEqb$ü”Ÿ°"à¼"…A¥2H*•Td`± ƒÕÊK l§s9 FØ¡»ðhŠí®#FIãH80~|F)‡‰‰‡Qzˆ“r  œœži¤¥¦¤"&ª$!;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/radio-au.gif0000644000176200001440000000033714656355210024325 0ustar liggesusersGIF89aÄ­žŒ÷ïïïëçïççÞÛÖÞ×Ö½®¥Þ×ÎƾµÿξµçãÞçßÞƺ­µªœÿÿÿÿûÿ÷÷÷÷ó÷çã罶­µ¢”ÿ÷÷Îý!ù ,\`"ŽdižèH4P5Dª8×±,…¡œ Å–äñ@ìHÇ"@l ±Qã2:‰+R¥ ¹6#`ôÚ™&Á֬ʇ–³‘<":)+-/Q)ˆ‰'!;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/combo-rd.gif0000644000176200001440000000100014656355210024312 0ustar liggesusersGIF87aÕÿó÷÷÷ï÷óï÷ïï÷ëïïóçïïçïëçïççÞßÖÞÛÖÞÛÎçëÞççÞçãÞçßÞçÛÞƶ­ÿÿÿ÷û÷÷÷÷÷ó÷÷ï÷ï÷ïïóïïïïïëïïëÞïçÞïãÞçãÖçßÖçÛÖÿ÷÷A,þÀ(B,ÈÈPÂl:ŸPIDB¡L¬!J(›dµÞð” ªå@¹ TÖëé¥"pÏßø€`T.S{{ƒ{‚ŒS“—•’˜“”‘¡£¥¢¥¢S¦±¢£±£°S¾°¾³Á¾·Á½ÃÊËËɾ ÊÐÌÁ½ ÚÙÙØÞÜÈÙÐåäÐÛëèÛSÖÛäÜè×õõ S üì ÿö±C0¥9ƒ öK¸Crü òKÈÏaE…ýøäPÐAA6Ùa¤Ç‘LyàÁK—0_>pÐòÁL—S@øð!&OŸtöܹSè‡) ’*±”iR§KŸ.hª„Õ«X³j’¤k’ ;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/scale-vd.gif0000644000176200001440000000052614656355210024322 0ustar liggesusersGIF89aÄïëçïççïãçÞãÖÞßÖÞÛÖÞ×ÖÞÓÖÖ×ÎÞÛÎÞ×ÎÞÓÎÿçëÞççÞçãÞçßÞçÛÞƶ­ÿÿÿÿûÿïçÞïãÞçãÖçßÖçÛÖç×Ö!ù ,Ó “IdiJ™(MlëNè Ál7óBNuø¿ n(:‚Åâprª–êÔ»ÝrÓ‡åÑí–—¸|ŽÞ= qÈE¯¯ð'|Kˆˆ‹KŽ‘‘„’'‰ˆ›;¦¦¥K¦'­KŸ K °¾¼K ÆÉÆ»ÈÇÏË; ÕÙ KØÙÞÚK  åÞè;Þåî  Kòôðöñ1õúò(*'')B;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/sbthumb-hd.gif0000644000176200001440000000040714656355210024657 0ustar liggesusersGIF87aÄÿó÷÷÷ï÷óï÷ïï÷ëïïóçïïçïëçïççïãçÞßÖçëÞççÞçãÞçßÞƶ­ÿÿÿ÷÷÷÷ó÷ïóïïïïïëïïçÞïãÞçãÖçßÖçÛÖ,Œà#ŽdiBhª®©R H1 k®àK¾à$(™HxHa0™ –̨sˆ„ (”A›ínµÕƒ¡b8˜+‚`.‡ˆC a[ 9uVpCm-_ …5\‰H XxP‚ ir. ‹qD<šOe-³´µ³&¸#!;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/scaletrough-v.gif0000644000176200001440000000015714656355210025407 0ustar liggesusersGIF89a‘Ö˽ƶ­ÿ­žŒ!ù,@”=™Ç7Gk9]°8‹zyÈŠ`—âG¢“j¶+ìÑ©s3^ó·ž+õ€CáÏøò%‰GEùd.‘Q*C±`;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/check-ac.gif0000644000176200001440000000051314656355210024256 0ustar liggesusersGIF89aÕ­žŒsuskikZ]ZRQRJIJµ¶µµ²µ­®­­ª­ÿœšœ”–””’”„‚„ÿÿÿÿûÿ÷÷÷÷ó÷ïïï989ççççãç101ÆÃÆ ÿ÷÷A!ù ,hÀ…pH,È€rÉ\ ¨t ˜ª4Ë‚A ;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/arrowdown-a.gif0000644000176200001440000000036514656355210025065 0ustar liggesusersGIF87aÄ÷ûï÷÷ï÷óï÷ïïïóçïïçïëçïçç„uk{ukçëÞççÞÿÿÿ{ucÿûÿÿ÷ÿ÷ÿ÷÷û÷÷÷÷÷ó÷ï÷ïïóïïïïïëïçÛÖÿû÷ÿ÷÷,z`ƒŒdI&£®ìŠ$Œæ@³#;8&Æ‘öôÀHób6’È Ù(‡(ÆDB LTª.% d¾àÌ„B„ ƒpFP©`¢…¥–ÄÃP¸ ƒD) ‰ŠŠoz ‡o) ˜šš™e ¡¢£¡"&§$!;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/arrowdown-p.gif0000644000176200001440000000037014656355210025100 0ustar liggesusersGIF87aÄÞÛÖÞ×ÖÞÓÖÖÛÎÖ×ÎÖÓÎÖÏÎÖËÎÎÓÆÎÏÆÎËÆÎÇÆÎÃÆkiZÞÛÎÞ×ÎÞÓÎÖÓÆÖÏÆÖËÆkickecsecƶ­ÆǽçÛÖÎ˽ÎǽÎý,} cdIV¦®ìz¥@ ¸æ\˜PàŸ¯Ñ 0…A!Yˆ(•F^Ä@5L«]Ê x¿€C˜:(à°bÅ(( Åñ¦h.ÌbAÙö{#  ‡‡†Fy  ’m›œ šw)¤¥¦¤;&ª$!;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/radio-du.gif0000644000176200001440000000034214656355210024324 0ustar liggesusersGIF89aÄ­žŒ÷ïïïëçïççÞÛÖÞ×Ö½®¥Þ×ÎƾµÆºµÿçãÞçßÞƶ­µªœÿÿÿÿûÿ­¢”÷÷÷÷ó÷çã罶­ÿ÷÷Îý!ù ,_ "Ždižèx45Gš8×±,…‘œIÅ–äñ@ìHÇ"@l ±QãB:‰„)R˜\›’ 0~‰€íàL “ö#‹4È¡¥âlä:)+-/Q)‹Œ'!;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/check-du.gif0000644000176200001440000000014014656355210024277 0ustar liggesusersGIF89a‘­žŒÿÿÿÿÿ÷÷!ù,1Œ©Ëà£Ú;À¢û¯ÔG ¡1–Þ¤ª¹½ëª4'ß2,⯞›D†,†ñ˜(;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/tree-p.gif0000644000176200001440000000064414656355210024021 0ustar liggesusersGIF87aÄÞÛÖÞ×ÖÞÓÖÖÛÎÖ×ÎÖÓÎÖÏÎÖËÎÎÓÆÎÏÆÎËÆÎÇÆÎÃÆkiZÞ×ÎÞÓÎÞÏÎÖÓÆÖÏÆÖËÆÖÇÆkickecsecƶ­Æ˽ÆǽÆýçÛÖÎ˽ÎǽÎý,þ`cdižÖUalë¾0V­@0uìÀè>§qÁØv;ßéS8–!@˜N©Xëî:, ê7‘EB’èÄ D  oD#‰ d‚†–‹DŠ—"JdnprtC d¸df\ŒZIKMO´IÈÉFA;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/radio-ac.gif0000644000176200001440000000054414656355210024303 0ustar liggesusersGIF89aÕ­žŒ÷ïïïëçïççÞÛÖÞ×Ö½®¥{y{sqsZYZJIJÞ×Îƾµÿœšœ”–”ŒŽŒÎ¾µçãÞçßÞƺ­œ–”µªœÿÿÿÿûÿ÷÷÷÷ó÷9<9989çãç),)½¶­! !µ¢”ÿ÷÷ÎýA!ù,@‡pH,Èa¡" ˆ*…¤äBbL&†ƒä(Q#Lƒil‰…ËD`é:ò!:¬<@)x)xm„‚‰m)ƒƒŽ“žŸ ‘ž*§¥'' ¥²²©®!¼¼¿¬®+Ã+ÆÆ%¯Ç³²++¬ÍÅ+½¼×%$ ,,,ââá&ÞâÐë$Þ,,Ù!,,## ïZh ~þZ€a¡Ã…ÿ5<ЂaEˆ"€8p „:†„ ÁA C¦y@‚ˆ“$DHAfÊš N¦”ÉSB œJԧџ 0(Ê(”2˜Jµ*Ô ;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/toolbutton-d.gif0000644000176200001440000000076314656355210025261 0ustar liggesusersGIF87aÕÿó÷÷÷ï÷óï÷ïï÷ëïïóçïïçïëçïççÞßÖÞÛÖÞÛÎçëÞççÞçãÞçßÞçÛÞƶ­ÿÿÿ÷û÷÷÷÷÷ó÷÷ï÷ï÷ïïóïïïïïëïïëÞïçÞïãÞçãÖçßÖçÛÖÿ÷÷A,þÀ(B,G0"i:ŸPhd(¡P&×%¤ÕN´ÛïdȤ(ë9p¶•v€,¹Tp{|ø÷t~~„~ƒt“—•’˜“‘ ¢¤¡¤t¥¯¡¢¯¢t»®»±¾»µ¾ºÀÅÆÀÄ» ÅËÇKL ÖÕÕÔÚÖtÕËàßË×æãtÒ×ßØãÓïïÞ óç öæt ßýýèÌÇaà7~óÎ+¸0 ½y ø9èà`bÅ;`œˆ±<€Irä!œ¤“‡ ^ƄЦK—-é(Ø©DOŸ;ö º`ˆQH“*]ªtÊ3$P“;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/toolbutton-n.gif0000644000176200001440000000105514656355210025266 0ustar liggesusersGIF87aÕÿó÷÷÷ï÷óï÷ïï÷ëïïóçïïçïëçïç眒{œŠ{ÞßÖ”‚sÞÛÖÖÓÎÎËÆœ’„œŽ„œŠ„„ysÞÛÎŒ}sŒys„}k„yk„uk{uk„‚sçëÞççÞçãÞçßÞçÛÞÿÿÿ{uc÷û÷÷÷÷÷ó÷÷ï÷ï÷ïïóïïïïïë{”†{”‚{Œ†sŒ‚sïëÞïçÞïãÞçãÖçßÖçÛÖÿ÷÷A,þÀÃ#C,LJ0j:ŸPhæ¡ ‘H#¬dÛnG[.xT1Iàš¤¯€@é¨e0¡SI ×Ïÿ‚5!&‚‚&(‹‚((Š(†x)›))Ÿš ›5!)¬®««)­«5!¼¼­*®½®5!̼̽ÏÏÃϸºÑ×Ø×5//ËÏ×àÙ5--Ë00íììëñí5 .!ìàúùàîû•c"»|ïú©[¸°† ‚btCňk°X¢C>(|Ñ‚ jä±CÂAtÙNG‘5ŠÔ˜ñd4 œÙqdÍŒ(+4À8Á¦5Ïž=;Ù³Œ6‡ú\*@ ($˜€ª :$¨Ú3ë§  ˆJ¡¬Ù³hÏ;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/combo-rf.gif0000644000176200001440000000104614656355210024326 0ustar liggesusersGIF87aÕ÷÷ï÷óï÷ïï÷ëïïóçïïçïëçïç眒{œŠ{ÞßÖÞÛÖÖÓÎÎËÆœ’„œŽ„œŠ„„ysÞÛÎc]RŒ}s„}k„yk„uk{uk„‚sçëÞççÞçãÞçßÞçÛÞÿÿÿ÷û÷÷÷÷÷ó÷÷ï÷ï÷ïïóïïïïïë{”†{”‚{Œ†sŒ‚sïëÞïçÞïãÞçãÖçßÖçÛÖÿ÷÷A,þ@CãB,ÈËðÃl:ŸÐæ ¬³Ð,›eµÞð…: •'ôÙœN‡Uˇ$ DtÑ}èë'x#€}#%}Š%%#}r&–&&š˜•›—&¨¨&¬&ª¬«­·¨'©¶­¿¹ɶÉ̽Í´ÌÒÓÔÇÉ,ÅÖÓÛÔÒ*Å--æååäêÝ+Çèåèç÷ôæ)âç·åG0= üâmp±Ÿ‡\à;€âÀ\\¨1¢‹Ž"n¨¸aÂF†Qn\Èð¢‹9¼à “憚/nÊ,9“L„&Àèc¨Q¢C9íÐAix˜ƒê¦NÅZµª‡1|X@v ³gɦ5«V‚YdÈK·®]à:ØË·¯ß¿A;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/sbthumb-ha.gif0000644000176200001440000000042414656355210024653 0ustar liggesusersGIF87aÄ÷ûï÷÷ï÷óï÷ïï÷ëïïóçïïçïëçïçç„uk{ukçëÞççÞÿÿÿ{ucÿûÿÿ÷ÿ÷ÿ÷÷û÷÷÷÷÷ó÷ï÷ïïóïïïïïëïïçÞçÛÖÿû÷ÿ÷÷,™ “ŒdišMª®¬š(ÍöDó#?øFËšKp( !šWÀ™H8€ çIX5ŠDƒb(®õ ÆjJEÀ¦Ôn´ <^`±ðxIZ„…‡ŒI ”’•˜‚‘  ¡¢ Ÿ ¨¨¨©©©f ´¶¶µº X0ÀÁÂÃÀ'ÆÇ!;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/combo-rn.gif0000644000176200001440000000102514656355210024333 0ustar liggesusersGIF87aÕÿó÷÷÷ï÷óï÷ïï÷ëïïóçïïçïëçïç眒{œŠ{ÞßÖÞÛÖÖÓÎÎËÆœ’„œŽ„œŠ„„ysÞÛÎŒ}s„}k„yk„uk{uk„‚sçëÞççÞçãÞçßÞçÛÞÿÿÿ÷û÷÷÷÷÷ó÷÷ï÷ï÷ïïóïïïïïë{”†{”‚{Œ†sŒ‚sïëÞïçÞïãÞçãÖçßÖçÛÖÿ÷÷A,þÀƒãB,ÈËðÃl:ŸÐæ ¬³Ð,›eµÞð…ªå@¹ ˆÖkˇ$¸éï|@ÀÏ D$#||#%…|%%„Žr&•&&™—”š•–&¥§¤¤&¦¤¦&´´¦'§µ§·´µÅŻȲÇÍÎÏ,ÁÅÍÔÏÅ*Á--ßÞÞÝãá+ÞÔëêÔàñîà)ÛàêáîÜüüõ¸Ø0Pžƒå!@ñaƒ:‡Œ(ÐEu”8ÐbG‰:t¡ !‡N¦Ü òË“,Qrˆð¡ 6qêÌÙÃ;Í=q&ø°ÀCŒ Ž&õP©Q£Mc@øÀ *W±VÕzuë„« ÈK¶¬Ù³2„}À¶­Û·pƒ;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/sbthumb-hn.gif0000644000176200001440000000042614656355210024672 0ustar liggesusersGIF87aÄÿó÷÷÷ï÷óï÷ïï÷ëïïóçïïçïëçïççïãçÞßÖ„uk{ukçëÞççÞçãÞçßÞÿÿÿ{uc÷÷÷÷ó÷ïóïïïïïëïïçÞïãÞçãÖçßÖçÛÖ,› ´ŒdišQª®¬º0Q@SÈ5Ë2'F‚ %H¬) ç) *•óI9ŒEd`± _¯üÅj†‹áÀ¾{탈C>ÏîëKZxƒˆxxK ’“– ŸŸ£ž¨ž«©ªf  ··¹¹¶X0ÂÃÄÅÂ'ÈÉ!;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/comboarrow-a.gif0000644000176200001440000000067114656355210025215 0ustar liggesusersGIF89aÕ÷÷ï÷óï÷ïïïóçïïçïëçïççÎËÆ„ukÿ{ukçëÞççÞçãÞÿÿÿ{ucÿûÿ÷ÿ÷÷û÷÷÷÷÷ó÷ï÷ïïóïïïïïëïçëçïëÞïçÞïãÞçÛÖÿû÷ÿ÷÷A!ù ,Ö@„pH$ ‡rÉ\"IĉL«Ø")‘X!^Èçî<T©,^¯µhP·+—O$ Ž}Mü}wp€‚ˆ€fh‡Ž‡’Z——zhœ£¤ŸB¥œ©h­¤µµzI¾®¿Ã„ÃÃÂÉz•ÐËÓÒ„ØÛÜÛZIÛá äá åä åîíßä öäö ‹  þ HÉAƒ"dpП¼#J„ø¤ˆÅ!G‚;tcltk2/inst/tklibs/ttktheme_clearlooks/clearlooks/button-a.gif0000644000176200001440000000122514656355210024352 0ustar liggesusersGIF87aÕ÷÷ï÷óï÷ïïïóçïïçïëçïç眒{œŽ{œŠ{œ†{ÖÓÎÎËÆœ’„œŽ„„}sœŠ„„ys„us”}{Œ}sŒys„}k„yk„uk{ukçëÞççÞçãÞçßÞÿÿÿÿûÿÿ÷ÿ÷ÿ÷÷û÷÷÷÷÷ó÷ï÷ïïóïïïïïë{”Š{”†{”‚{ŒŠsŒ†sŒ‚sïçÞïãÞçãÖçÛÖÿû÷ÿ÷÷A,þÀC,È"Cˆñ8ŸÐ¨ô‰ad¦Ø¬gFô|BŸì yÇ_±Wüá^ÊœžÇiiü|v‘x@"44"€‚ƒ €…„"|o5"#‘"’’”–”—3#5#5¢¨#ª¤ª£­#3§µ#$§¹¹¢¹µ$° »»%¶¶¹Ç¾¿3$%Ç%Ö$ÛÚ×ÇßÚÒ/&Ëçèéè$êíçÒÔìê&îêîËùõãå˘x'0À‚& ˜ñ‚…¹˜0!=‰çL 8ƒ…CŠnÔxpäHg¸Xáa£—O4!Ó¥À‘3V´ð@àÄ»Æ>eÝH艢jæd 4©Ð I_ž¨)³çÆœ < @`kׯG¿rÊÕë *xn=¶jÒ¯^ö<›ÀCò@‘¯^¼~ýæ‘‚]4h(°¸€Æ#7Nìx„6hFl`ó†Î04½!ô†xàÀ!†èÖ6Ć£µfÖµg8pàAßXËèü·ïß‚Ëð=ãÀ‚3¢KŸN½ºô * * Released and tagged Tklib 0.7 ======================== * 2013-03-25 Andreas Kupries * * Released and tagged Tklib 0.6 ======================== * 2009-01-21 Andreas Kupries * * Released and tagged Tklib 0.5 ======================== * 2005-11-10 Andreas Kupries * * Released and tagged Tklib 0.4.1 ======================== * 2005-11-02 Andreas Kupries * * Released and tagged Tklib 0.4 ======================== * 2005-03-31 Aaron Faupell * Fixed argument handling again, added -geometry option 2005-03-22 Aaron Faupell * tk_getString.tcl: tweaked padding, made focus -force for windows, fixed namespace, moved variable from ::tk to own namepsace, fixed argument handling 2005-03-17 Aaron Faupell * initial import tcltk2/inst/tklibs/getstring0.1/tk_getString.tcl0000644000176200001440000001017715017041713021324 0ustar liggesusers# tk_getString.tcl -- # # A dialog which prompts for a string input # # Copyright (c) 2005 Aaron Faupell # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: tk_getString.tcl,v 1.11 2005/04/13 01:29:22 andreas_kupries Exp $ package require Tk package provide getstring 0.1 namespace eval ::getstring { namespace export tk_getString } if {[tk windowingsystem] == "win32"} { option add *TkSDialog*Button.width -8 widgetDefault option add *TkSDialog*Button.padX 1m widgetDefault } else { option add *TkSDialog.borderWidth 1 widgetDefault option add *TkSDialog*Button.width 5 widgetDefault } option add *TkSDialog*Entry.width 20 widgetDefault proc ::getstring::tk_getString {w var text args} { array set options { -allowempty 0 -entryoptions {} -title "Enter Information" } parseOpts options {{-allowempty boolean} {-entryoptions {}} {-geometry {}} \ {-title {}}} $args variable ::getstring::result upvar $var result catch {destroy $w} set focus [focus] set grab [grab current .] toplevel $w -relief raised -class TkSDialog wm title $w $options(-title) wm iconname $w $options(-title) wm protocol $w WM_DELETE_WINDOW {set ::getstring::result 0} wm transient $w [winfo toplevel [winfo parent $w]] wm resizable $w 1 0 eval [list entry $w.entry] $options(-entryoptions) button $w.ok -text OK -default active -command {set ::getstring::result 1} button $w.cancel -text Cancel -command {set ::getstring::result 0} label $w.label -text $text grid $w.label -columnspan 2 -sticky ew -padx 5 -pady 3 grid $w.entry -columnspan 2 -sticky ew -padx 5 -pady 3 grid $w.ok $w.cancel -padx 4 -pady 7 grid rowconfigure $w 2 -weight 1 grid columnconfigure $w {0 1} -uniform 1 -weight 1 bind $w [list $w.ok invoke] bind $w [list $w.cancel invoke] bind $w {set ::getstring::result 0} if {!$options(-allowempty)} { bind $w.entry [list after idle [list ::getstring::getStringEnable $w]] $w.ok configure -state disabled } wm withdraw $w update idletasks focus -force $w.entry if {[info exists options(-geometry)]} { wm geometry $w $options(-geometry) } elseif {[winfo parent $w] == "."} { set x [expr {[winfo vrootx $w] + [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2}] set y [expr {[winfo vrooty $w] + [winfo screenheight $w]/2 - [winfo reqheight $w]/2}] wm geom $w +$x+$y } else { set t [winfo toplevel [winfo parent $w]] set x [expr {[winfo vrootx $w] + [winfo width $t]/2 - [winfo reqwidth $w]/2}] set y [expr {[winfo vrooty $w] + [winfo height $t]/2 - [winfo reqheight $w]/2}] wm geom $w +$x+$y } wm deiconify $w grab $w tkwait variable ::getstring::result set result [$w.entry get] bind $w {} grab release $w destroy $w focus -force $focus if {$grab != ""} {grab $grab} update idletasks return $::getstring::result } proc ::getstring::parseOpts {var opts input} { upvar $var output for {set i 0} {$i < [llength $input]} {incr i} { for {set a 0} {$a < [llength $opts]} {incr a} { if {[lindex $opts $a 0] == [lindex $input $i]} { break } } if {$a == [llength $opts]} { error "unknown option [lindex $input $i]" } set opt [lindex $opts $a] if {[llength $opt] > 1} { foreach {opt type} $opt {break} if {[incr i] >= [llength $input]} { error "$opt requires an argument" } if {$type != "" && ![string is $type -strict [lindex $input $i]]} { error "$opt requires argument of type $type" } set output($opt) [lindex $input $i] } else { set output($opt) {} } } } proc ::getstring::getStringEnable {w} { if {![winfo exists $w.entry]} { return } if {[$w.entry get] != ""} { $w.ok configure -state normal } else { $w.ok configure -state disabled } } tcltk2/inst/tklibs/getstring0.1/example.tcl0000644000176200001440000000025614656355210020320 0ustar liggesuserssource ./tk_getString.tcl #package require getstring namespace import getstring::* if {[tk_getString .gs text "Feed me a string please:"]} { puts "user entered: $text" }tcltk2/inst/tklibs/ttktheme_keramik/0000755000176200001440000000000015017041713017251 5ustar liggesuserstcltk2/inst/tklibs/ttktheme_keramik/keramik_alt/0000755000176200001440000000000014656355210021544 5ustar liggesuserstcltk2/inst/tklibs/ttktheme_keramik/keramik_alt/vsb-h.gif0000644000176200001440000000036014656355210023251 0ustar liggesusersGIF87a„’’’ÿÿÿäääûûûúúúèèèéééÖÖÖÓÓÓàààñññêêêÏÏÏÑÑÑùùùþþþÞÞÞïïïÒÒÒßßßãããôôôøøø———vvvÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ,u ŒdY€ ®ì Â@´…q É›*KKŒFÆ£ Žá®Çz“:AqUp"•R¦R}b§Ûî5 æZ¡D­ÙKV‹ÑËÕzœ–¿¿î3Þ®o·ú0FX- X“*QŠŠ/Ÿ ¡¡!;tcltk2/inst/tklibs/ttktheme_keramik/keramik_alt/hsb-h.gif0000644000176200001440000000035114656355210023233 0ustar liggesusersGIF87a„———’’’vvvÿÿÿÞÞÞßßßàààäääãããïïïñññûûûôôôúúúþþþøøøùùùèèèêêêéééÓÓÓÒÒÒÑÑÑÏÏÏÖÖÖÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ,n ŒdižÂ ®lÛiaGmß72ÀC‚(‹ p8dìR —ò•r,ŸÇªäM¬VëâAVŽ°xÌ”J#è´í`8yƒ…dN¯Û%Ñø}/™P¢„…†…QŽG”•–—˜"'››!;tcltk2/inst/tklibs/ttktheme_keramik/keramik_alt/hsb-a.gif0000644000176200001440000000055614656355210023233 0ustar liggesusersGIF87a¥———‰‰‰vvvÿÿÿ‡‡‡ÈÈÈÇÇÇÉÉÉÎÎÎÍÍÍÚÚÚÜÜÜæææßßßíííðððñññõõõüüüåååòòòøøøîîîéééãããìììëëëäääÒÒÒÔÔÔÓÓÓ½½½¼¼¼»»»¹¹¹¿¿¿ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ,“@@`H,‚rÉl6 ÉBÁp¨Z¯WÄ:H ‹°xˆ| €‚^5j°$\ˆ°¡Ã‡jÎ`Ò£0˜Á¤ Aƒ©¨)¢I5iÐhùq#'’ð áƒËÇyUÒ5I³sg½Ÿ)ÏhéAƒG’"ŠäÁCËMuUР2µªÔ«X³¢!£E‡ŒEDt rã…Ž+OÓE­J•ªÖ·þhÎŒ¹¢ãÅ "4©á•´iª˜1³ƒ°áÁˆ+.† 5†hÀ0„F RW!C†FçÏœC‹=Œ-h Á`A 6šhþòåEíÛ´sëÞ fK,h±ÐúuìÙ_P$_¾»yîÞ¿ƒŸàz%š·l)±½»öïàçZBú *« ‘D3,!àËO¿¾ý*S’ÐX?$„ê3¡P|Pà&¨ ‚RÈŽy4@Äk3¡™Npá†v衇­@aÄ ÖÑEÜZš}ÃÁ/¾øÍŒ4ÒØMAƒ 7Á@Hì ,„“‹0&µYã’ß0AŠ6È° €„6Ùb’12ɤ“L ¡ƒ B a€:Áà BtNNzÀ„œr‚iç8¶¢„>¡ÃŒpD=üp3T¡¨¢N‚À„£Žâ)éRLÑE AÂ,$àÃF AD0¢|Є©¦ŠJ1R4èD XðGˆÐI ¡k¼öêë¯ÀúÊDÄa‚H’‚àì³ÐF+í´Ò€@‚;tcltk2/inst/tklibs/ttktheme_keramik/keramik/arrowleft-n.gif0000644000176200001440000000044414656355210023635 0ustar liggesusersGIF89a„sss”””ÓÓÓÔÔÔÕÕÕ×××ÛÛÛÞÞÞàààáááãããäääåååçççèèèéééëëëíííîîîïïïóóóôôôõõõööö÷÷÷ùùùûûûýýýÿÿÿÿÿÿÿÿÿ!þCreated with The GIMP!ù ,ˆ ŒdiŠ£®¬êPc“ JmßK+Ìý@ …3rD*˜$ ÉÔlt“Ñš¬¦ªE§˜«øŠÑ`&1Še‚„bÁh:ŸÐ…"!@& ‡vËí6®UÁrˆ˜ÏèôòK&¡Í>,щd2åA) ëíêïðð Ý!"#$%e|˜+A»ƒñÆ3À ĈD˜˜â"(˜ÁBÇ  Æ`„Å &Pl‘BÅ‚Œ!p¦Í™8sêÔ€ÁŠ#6 `ñáD /`šƒ €§P›J:UC /\´8ñ… 3Lˆ¸ ”`Ъ=˶­[þ%.HœÁA 5lÔ¨Pvc‰* þK¸°a *ä­áÆ ¼8j`è A‡Ž—3[Þ̹sjDöpcä(wêÁ€5kQ¢ð  šñÓµS ŒÙÉß¾a‡’M{ôŽRI„r„B KN½ºu<Ð-÷ðcHr"E6P~ñâHùóäÓ«_ÿÂȆ"DRx‚$9$(SR?ÿ` LðAÛ!± ¢áGÙ0á„Vhá…Þ|PDd$,ÑDQ&¤ÀÁƒJ(!†(VøA &pÕ„¨D #&R˜â…~0C*PàÄAx0”a¨€K6©ä“PB9AA¬ ‚<E+àA@AÄŒI¦€hsy„Â+LAEA|`4°|ò  hšh¾€CÁXdá„Al@ãÀ¥˜*ဦšbêé§úÀá[üÁE^Œ@A¼ÚÁ¬´Öjë­µVÐÀ®|F’  Ʊkì±È&›lfœ!H ;tcltk2/inst/tklibs/ttktheme_keramik/keramik/spinup-n.gif0000644000176200001440000000007014656355210023141 0ustar liggesusersGIF89a€ÿÿÿ!ù ,Œ©Ë€„NNf3Ý´;tcltk2/inst/tklibs/ttktheme_keramik/keramik/arrowup-p.gif0000644000176200001440000000041714656355210023331 0ustar liggesusersGIF89a„+++111777>>>???CCCEEEJJJQQQRRRXXX^^^```fffßßßÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!þCreated with The GIMP!ù ,s Žd)* ´(l¢1"¬5™˜™ H & $!;tcltk2/inst/tklibs/ttktheme_keramik/keramik/radio-u.gif0000644000176200001440000000125614656355210022737 0ustar liggesusersGIF89aÆa+++666IIIJJJXXX\\\___eeejjjlllpppqqquuuwwwxxxyyy{{{}}}~~~€€€‚‚‚ƒƒƒ†††‡‡‡ˆˆˆŠŠŠŽŽŽ”””–––———™™™šššœœœžžž¢¢¢¤¤¤¥¥¥ªªª¬¬¬°°°±±±²²²³³³µµµ¶¶¶¸¸¸¹¹¹ººº»»»¼¼¼¿¿¿ÀÀÀÁÁÁÂÂÂÃÃÃÄÄÄÆÆÆÇÇÇÈÈÈÊÊÊËËËÌÌÌÍÍÍÎÎÎÏÏÏÐÐÐÑÑÑÖÖÖ×××ØØØÙÙÙÜÜÜßßßáááâââãããåååèèèêêêëëëíííîîîðððòòòôôôõõõööö÷÷÷øøøùùùûûûüüüýýýþþþÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!þCreated with The GIMP!ù ,ò€@‚ƒ„…†„G`ŠŠG‡ƒB`NSY[WTLEBŽ=HL>; >NJ=‡7C@89/BC5?„62@/MP½F(A24„(;* S\^_^\0*;%>ƒGS]‹‹G9ƒVZÜ‹U 3ƒDÛè`C .ƒ+.ôŠ-Ž±d¢‚”Š°páÆd„|ƒ’‚^B´¤b&OžD¡òdɇN„äãD#j ÑQ" bP#ģł`€Â‡< ý࣠,p(ƒ­C>rÌpÁÂÅŒ;‰%;tcltk2/inst/tklibs/ttktheme_keramik/keramik/arrowleft-p.gif0000644000176200001440000000042014656355210023631 0ustar liggesusersGIF89a„+++111777>>>???CCCEEEJJJQQQRRRXXX^^^```fffßßßÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!þCreated with The GIMP!ù ,t Žd9Eª®©¡ˆ1tm LÆáÿ?Dd@,Èréxä.¤#qX ë ªHR¿J춠`€ÁHÆÖuF3 ¢bѦ.‹õ831&¸º¼¾Àƒ6¹»½¿ÁÃÌÆÏÉËÅÎÈ‚ÊÄÍÇŒ01-476:<)Ø.+("©,2é(()'%'(. ·Œ>˜8"‚X]ªpˆ4\´á‚…‹NÜ8(;tcltk2/inst/tklibs/ttktheme_keramik/keramik/vsb-t.gif0000644000176200001440000000017414656355210022430 0ustar liggesusersGIF89a ã ££¦ÎÏÒÕÖÙÜÝàæçêîïòóõøøùýûüÿýþÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!ù , )1H1¥Í¤¦q›7UWF–*®‰ ¦#)»êz‡¹ÝòµÎD;tcltk2/inst/tklibs/ttktheme_keramik/keramik/button-d.gif0000644000176200001440000000236214656355210023132 0ustar liggesusersGIF89aç  !!!"""###$$$%%%&&&'''((()))***+++,,,---...///000111222333444555666777888999:::;;;<<<===>>>???@@@AAABBBCCCDDDEEEFFFGGGHHHIIIJJJKKKLLLMMMNNNOOOPPPQQQRRRSSSTTTUUUVVVWWWXXXYYYZZZ[[[\\\]]]^^^___```aaabbbcccdddeeefffggghhhiiijjjkkklllmmmnnnooopppqqqrrrssstttuuuvvvwwwxxxyyyzzz{{{|||}}}~~~€€€‚‚‚ƒƒƒ„„„………†††‡‡‡ˆˆˆ‰‰‰ŠŠŠ‹‹‹ŒŒŒŽŽŽ‘‘‘’’’“““”””•••–––———˜˜˜™™™ššš›››œœœžžžŸŸŸ   ¡¡¡¢¢¢£££¤¤¤¥¥¥¦¦¦§§§¨¨¨©©©ªªª«««¬¬¬­­­®®®¯¯¯°°°±±±²²²³³³´´´µµµ¶¶¶···¸¸¸¹¹¹ººº»»»¼¼¼½½½¾¾¾¿¿¿ÀÀÀÁÁÁÂÂÂÃÃÃÄÄÄÅÅÅÆÆÆÇÇÇÈÈÈÉÉÉÊÊÊËËËÌÌÌÍÍÍÎÎÎÏÏÏÐÐÐÑÑÑÒÒÒÓÓÓÔÔÔÕÕÕÖÖÖ×××ØØØÙÙÙÚÚÚÛÛÛÜÜÜÝÝÝÞÞÞßßßàààáááâââãããäääåååæææçççèèèéééêêêëëëìììíííîîîïïïðððñññòòòóóóôôôõõõööö÷÷÷øøøùùùúúúûûûüüüýýýþþþÿÿÿ!ù ÿ,þÿýCwÎœÁƒš;‡Nà?säÈ•Sgn8oÝ2f䶭ã¶náÌ=ÔÎÅræÊ©TIÎ[¶kÚbr#Ç Û6lÚÆ¡Kw®§Ï‚ä¾U“†Û5hÙ°I£Fî\ºtè¢JåIn[3¤ÙšÃ6MY´’?Þ#×™²iØŠíÊj¬8”b{B즬m¶]°ª) ¦ÌÛ8r ’×-ßj°JM3Öë7qW®,ŽÛ±^Ʀ•Â$Ø®bÛ‰‹Hš´¸pÛÔ“†©4aº†iw:œíÛ¢Ái¦K´F…^ç†í8ܸÁ}Ã&l8´Bu ÃÌšÆëØ­M­Îé·€ÐUãF¾¼yòÕ€Ýâ¾fŒt\¿¨eÓÆ-¦}úÚ²QûEÚ˜-Ñ4÷ ZÙhà\3\4[P±Ø.ÁHsà„NÌ.™QÁÄ5Êü"Œ„ùQ8Ÿ~Äü¢Ì5La 4Ä CTLIa##6#Z“L1Ð\SDÈèeLŽ÷Ý· yØ0ÃL5É$á†*ÖL³L3ÔØ´MÜtãÍ6ÒLsÍ*WØÂÄ2ÖT4ÕHéÑ ]™ 4MòO"D˜r¢Q×Ì8#}äMãŠe84 5¨ è „J‚;tcltk2/inst/tklibs/ttktheme_keramik/keramik/radio-c.gif0000644000176200001440000000126714656355210022717 0ustar liggesusersGIF89aÆb+++666IIIJJJXXX\\\___eeejjjlllpppqqquuuwwwxxxyyy{{{}}}~~~€€€‚‚‚ƒƒƒ†††‡‡‡ˆˆˆŠŠŠŽŽŽ”””–––———™™™šššœœœžžž¢¢¢¤¤¤¥¥¥ªªª¬¬¬°°°±±±²²²³³³µµµ¶¶¶¸¸¸¹¹¹ººº»»»¼¼¼¿¿¿ÀÀÀÁÁÁÂÂÂÃÃÃÄÄÄÆÆÆÇÇÇÈÈÈÊÊÊËËËÌÌÌÍÍÍÎÎÎÏÏÏÐÐÐÑÑÑÖÖÖ×××ØØØÙÙÙÜÜÜßßßáááâââãããåååèèèêêêëëëíííîîîðððòòòôôôõõõööö÷÷÷øøøùùùûûûüüüýýýþþþÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!þCreated with The GIMP!ù ,û€A‚ƒ„…†„HaŠŠH‡ƒCaOTZ\XUMFCŽ>IM?< ?OK>‡8DA9:0CD6@„73A0NQ½G)B35„)<+ T]_`_]1+<&?ƒHT^ÜŠH:ƒW[aÝÞaV4ƒE ^êÝŠD /ƒ,^\P´N‘‹c-°0…„¢,]…iB!‚¿AJLQ!Q‘’DÄ´‚@ˆ&P H©… PŒô…$l$ÙaBA!dP#ÔÃp = é!ÃD‡ .t0!£­C?tÐxÑâ C©%;tcltk2/inst/tklibs/ttktheme_keramik/keramik/hsb-p.gif0000644000176200001440000000061314656355210022404 0ustar liggesusersGIF89a¥'[fx\gzWo˜XpšXqšYq›Zs`y¤c|¦c|§d}§i«i‚¬n‡°qŠ²rŠ³|“º|”¼†•°˜¿†Ä‡žÅˆŸÆ‹¡Ç‹¡È¤Ê‘§Í’¨Î“©Ï“©Ð–«Ð—­Ò˜®Ó›°Ô›±Õž³Ø¢·Û¨¼à®Ãåÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!þCreated with The GIMP,—À€pH,“rÉl2’$CA­Z«‡Âèš0‘°x,†0\oij»ßíg’NŽH#‘~Ïß[ê& z …††‚ ]I!“”“‹^ ¡¡€¬­®€ µ¶·¸€¸¿µº€ÆÇÈÆ €ÏÐÑÒ uŒ×ØÙŒGÜGA;tcltk2/inst/tklibs/ttktheme_keramik/keramik/tab-p.gif0000644000176200001440000000155614656355210022405 0ustar liggesusersGIF89a ƶ¶¶uuuNNN<<<;;;ŒŒŒSSS®®®àààóóóßßßµµµ[[[ÑÑÑçççüüüþþþyyy©©©ÜÜÜùùùUUUÐÐÐÚÚÚ×××øøøýýýQQQÒÒÒõõõVVVÌÌÌÍÍÍòòò\\\ÔÔÔÇÇÇÉÉÉíííöööaaaÅÅÅÆÆÆèèègggÏÏÏÂÂÂÄÄÄðððkkkÎÎÎÁÁÁÃÃÃáááëëëqqqÀÀÀêêêwww¿¿¿|||âââ¾¾¾ÙÙÙÛÛÛÖÖÖÝÝ݇‡‡———ØØØ   ÕÕÕ¨¨¨ÓÓÓÊÊÊËËËÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!ù , þ€ˆ‰Š‚‚ ˜™š ‚ ©ª«§ ¹º»º¼ÊØÙÚÙÕ !¬è! "#$%&'÷øù'&%$#"þ hBÅŠ*L¸BEŠ(þ°háâ…3jÌèà…‹,$R´¸±$ÆŽCÆ1ƒF 6bÊœiÃD 3dÄøsCŽr¬J´èŠfàqã;fLXQ£ªÕ«5VL˜±„Ž?<>ìÀ1¡Ç¦³=&àØñØÌ>vüP¤®Ý»@üØá£-X¨;‚Á@¸°a B‚ìèê–`Á‡#'^ ¢ñãÁ‘ Ofüw1äÌ…7Wî3hÄŠ9;öl´hˬO~MúóiÚC.ÙÍ»·àÔ †ü!âG ¾“#DZ”ÈðâÇ“û^ÞüO‘8ƒ\0½»w#‚´lPäÏ$*^ŸÀ¾½û È_¨@räO$T~Ï?±ŠH$ñÇ-(±„HT£à‚Õ a -È’J4ÐÂ…f¨aJ0‘Â;tcltk2/inst/tklibs/ttktheme_keramik/keramik/arrowright-p.gif0000644000176200001440000000040214656355210024014 0ustar liggesusersGIF89a„+++111777>>>???EEEJJJQQQRRRXXX^^^```fffßßßÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!þCreated with The GIMP!ù ,f Žd)"¡®lˆ 1ÌtM$§¡ï¼8¢…pø. €Ál>Ì#ãP(žØ§± ¢²Y¡Â‹g‹Ã©l~$ êáО£ "–ê©'ˆ‚€…‹"5&“$!;tcltk2/inst/tklibs/ttktheme_keramik/keramik/spindown-n.gif0000644000176200001440000000007014656355210023464 0ustar liggesusersGIF89a€ÿÿÿ!ù ,Œ©«àX€QNgOÍœ;tcltk2/inst/tklibs/ttktheme_keramik/keramik/tbar-a.gif0000644000176200001440000000161314656355210022542 0ustar liggesusersGIF89aç  !!!"""###$$$%%%&&&'''((()))***+++,,,---...///000111222333444555666777888999:::;;;<<<===>>>???@@@AAABBBCCCDDDEEEFFFGGGHHHIIIJJJKKKLLLMMMNNNOOOPPPQQQRRRSSSTTTUUUVVVWWWXXXYYYZZZ[[[\\\]]]^^^___```aaabbbcccdddeeefffggghhhiiijjjkkklllmmmnnnooopppqqqrrrssstttuuuvvvwwwxxxyyyzzz{{{|||}}}~~~€€€‚‚‚ƒƒƒ„„„………†††‡‡‡ˆˆˆ‰‰‰ŠŠŠ‹‹‹ŒŒŒŽŽŽ‘‘‘’’’“““”””•••–––———˜˜˜™™™ššš›››œœœžžžŸŸŸ   ¡¡¡¢¢¢£££¤¤¤¥¥¥¦¦¦§§§¨¨¨©©©ªªª«««¬¬¬­­­®®®¯¯¯°°°±±±²²²³³³´´´µµµ¶¶¶···¸¸¸¹¹¹ººº»»»¼¼¼½½½¾¾¾¿¿¿ÀÀÀÁÁÁÂÂÂÃÃÃÄÄÄÅÅÅÆÆÆÇÇÇÈÈÈÉÉÉÊÊÊËËËÌÌÌÍÍÍÎÎÎÏÏÏÐÐÐÑÑÑÒÒÒÓÓÓÔÔÔÕÕÕÖÖÖ×××ØØØÙÙÙÚÚÚÛÛÛÜÜÜÝÝÝÞÞÞßßßàààáááâââãããäääåååæææçççèèèéééêêêëëëìììíííîîîïïïðððñññòòòóóóôôôõõõööö÷÷÷øøøùùùúúúûûûüüüýýýþþþÿÿÿ!ù þ,h Øè_ÁäÇ_Á… þÛGqŸD}õ]Ì(1ŸÇ|ñ‰Ä'ñžÉ{%OJ´ÇÒžÄz0뽌)‘žMzçéœ'QžOy=JŒG4žDxHáMÔgÍ›+[†¹£D‚j ;tcltk2/inst/tklibs/ttktheme_keramik/keramik/hslider-n.gif0000644000176200001440000000112014656355210023252 0ustar liggesusersGIF89a Æ[    ! #%')'-"1 6#;$=&@!%/ &1!(4*G+H#+7(,3%-<.M/O1R'0@ 3U 4W*3E!6Z*5G*5K%7X"8]#9_#9`$:b$;b%g&>h'>h1=T'?i'@k(@k(Am)Bn)Bo)Cp*Cq*Dr,Hx/Hv:G_KKMINVPPP:SJ\{OfXfklnlmoZp˜ftŒaxŸuvwpy‡yyzf|£}ƒsˆ­x±‘’‘‘‘”””—¦…™»™šŸ¥¯®®®¬°¸ÀÀÀÁÁÂÄÄÄËËËÌÌÌÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!þCreated with The GIMP!ù , ”€ZP>+.†)DUZS'7Q6%W@6L—˜L,G"EKŸ K49I¦§¦2-C­®­0!?´µ´+ =»¼»( 8ÂÃÂ& 5ÉÊÉ$ 3ÐÑÐ#1×Ø×/ÞßÞ)†æ†;*íî*R)ööø¼ž@òøÿ€|ƒ„…#‰Š‹#‘#•–— #›œ Ž‘¡ #¥¦§ #«¬­ $±²³°³·$»¼½"ÁÆÇÈA;tcltk2/inst/tklibs/ttktheme_keramik/keramik/spinbox-a.gif0000644000176200001440000000063114656355210023273 0ustar liggesusersGIF89a¥4ÀÀÀÁÁÁÂÂÂÃÃÃÅÅÅÆÆÆÇÇÇÈÈÈÊÊÊÌÌÌÍÍÍÏÏÏÐÐÐÑÑÑÒÒÒÓÓÓÕÕÕÖÖÖ×××ØØØÙÙÙÚÚÚÛÛÛÜÜÜÝÝÝÞÞÞßßßàààáááâââãããäääåååæææçççèèèêêêëëëìììíííîîîïïïðððñññòòòóóóôôô÷÷÷øøøüüüýýýþþþÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!ù ?,¶@l&s©NÈRh£Ñx@,(‹½PÌ“ùȤàYËB¶@(¯xÚ’@*”ÅE¯£V‚XØë'  t"  ˆ( ‘ .¢£. ¤£ ­¢ Ÿ¬¶¨¶. Å ²Å©Ò# ØÞ%+ òZ!),&$A;tcltk2/inst/tklibs/ttktheme_keramik/keramik/hsb-t.gif0000644000176200001440000000016714656355210022414 0ustar liggesusersGIF89a ã ££¦ÎÏÒÕÖÙÜÝàæçêîïòóõøøùýûüÿýþÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!ù , $È9ƒ½W轇ÿ!Žcaž§¡®ëá¾/"Ïsbßx®ï|ßSÀ;tcltk2/inst/tklibs/ttktheme_keramik/keramik/vsb-p.gif0000644000176200001440000000061714656355210022426 0ustar liggesusersGIF89a¥'[fx\gzWo˜XpšXqšYq›Zs`y¤c|¦c|§d}§i«i‚¬n‡°qŠ²rŠ³|“º|”¼†•°˜¿†Ä‡žÅˆŸÆ‹¡Ç‹¡È¤Ê‘§Í’¨Î“©Ï“©Ð–«Ð—­Ò˜®Ó›°Ô›±Õž³Ø¢·Û¨¼à®Ãåÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!þCreated with The GIMP,›À`H,“rÉ\&¦4}<—†ÃPx&‘Iâ`A DŽ¥Ñ¬¿ÄÑTèv^&m"uwƒy…ˆ€‹„‰l”Š‚“•‘™Ÿœ˜zš–’¢›—x¦£¬Œz|~ P"prt‹ {‹ Î ‚M×&^FÛDHÜÛA;tcltk2/inst/tklibs/ttktheme_keramik/keramik/button-h.gif0000644000176200001440000000160014656355210023130 0ustar liggesusersGIF89aÆîîîõõõúúúüüüìììïïïòòòùùùóóóèèèáááÞÞÞÝÝÝÜÜÜàààæææåååÚÚÚ×××ÛÛÛßßßûûûøøø÷÷÷öööãããÖÖÖÔÔÔÕÕÕØØØôôôýýýÿÿÿþþþÑÑÑÓÓÓÉÉÉÏÏÏëëëÎÎÎÀÀÀÒÒÒñññíííÐÐÐÈÈȶ¶¶ÍÍÍÅÅŬ¬¬ÊÊÊÃÃÃËËË¢¢¢¿¿¿êêꘘ˜ÆÆƾ¾¾‘‘‘½½½ÇÇÇäää»»»zzzºººçççtttÄÄÄlll¼¼¼ggg___ÙÙÙÌÌÌÂÂÂYYYbbbZZZ~~~°°°±±±fff‰‰‰“““XXX³³³ooo¹¹¹nnnIII???GGG^^^‡‡‡ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!ù ,þ€‡ˆ‰‰‚ ™š œ  ”¡¬   ¸ ÀÁ ´ !ÓÔÓ "#³"$ %! æçç&"' $( )$)*äèè!+,-) (\Dx£DäªQû0`Å /"¸ˆ¡AÆŒ+,|Øȱ£…4fÈУ‡6hܸ€°#ÇnатC rè ñ À@ƒ=à 96àر><\°@µ*Õ |ôàcÃŽ#`ÑÀD$hÓ `¢XÞ#~i*FCLèÝ«w„0ênB$,"(ð¡¸ñbÅŠŒAÄGŠHPPŠ‚çÏ¥H ƒƒ$ZpÕ°€Á‚d°´^ †Ž$Q²„ 8ÅÞ@BK”$i¢dDßć3˜®„FJš8¡!áE ìÓÇ_PjB‰h<¥ƒ†,4ä?Ý[4(‘2åH’H°²h¢ >$¨)$AÅUXà JD D…d˜!t¨ÁM`ñHZlÁʼn(¦˜b^|!H ;tcltk2/inst/tklibs/ttktheme_keramik/keramik/indicator-c.gif0000644000176200001440000000010314656355210023561 0ustar liggesusersGIF89a ¡ÇÇÇÿÿÿÿÿÿ!ù , Œ¢+¶°œ‚Ê{[xqÏÎtR;tcltk2/inst/tklibs/ttktheme_keramik/keramik/cbox-d.gif0000644000176200001440000000206414656355210022551 0ustar liggesusersGIF89a,Æ^***+++444555DDDEEEFFFIIILLLMMMPPPQQQTTTWWW[[[```ccceeekkknnnuuu}}}‚‚‚„„„………‰‰‰˜˜˜™™™ŸŸŸ¢¢¢£££¥¥¥¦¦¦©©©ªªª«««®®®¯¯¯°°°³³³µµµ¶¶¶···¸¸¸¹¹¹ººº»»»¼¼¼½½½¿¿¿ÀÀÀÁÁÁÂÂÂÃÃÃÄÄÄÅÅÅÆÆÆÇÇÇÈÈÈÉÉÉÊÊÊËËËÌÌÌÍÍÍÐÐÐÑÑÑÒÒÒÓÓÓÔÔÔÕÕÕÖÖÖ×××ØØØÙÙÙÚÚÚÛÛÛÜÜÜÝÝÝÞÞÞßßßàààáááâââãããäääåååæææçççèèèéééêêêþþþÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!ù ,,þ€ZYX†‡ˆ‰Š‹ŒYZ‚XVVW\XURPO›œžŸNM£MOSXWœRX®°W´µ¶·¸VPKIL¾NVNJMJLU,Ë,"YÏÐÑÒÓ’QGDÅJIBKJDFV]ä]J8ZZPêìéîïï[YVMAÜKA9JE>CR,Ê‘ƒ&%KÁ‚Ó>³òˆ"JrÀÀ§#È¿€¡Eɲq£Bj }T\Å5|@(°K!,J`Êd¤ÈJ•'=RA¢ˆ;œ°ÌHKÈ£Fq)µIÅÉ:Š„à@ŒM†–›gEHׯ“ŠKeJ‰8ˆpÐ ÄÆ‹þL´œ2ÅGÝ»tóêÝKE “/lÑ€¡­ J交{cJãÆ{#ç•E‰ÃB0T0l#‰â,P ÄM:´éÓ¨5%¹,¸ÂfÖž1n ­JíÚ©s‡~²s Bj´¨äó¦O#Åü á5„Pœ#Ÿ8±½»öïàÃk?BƒEt ‚·˜aä³/LàÃ÷E¿~}'L–™1\C\6CŸ-±„&hà‚ 6ØM46„ øC D˜ ‚:èá‚EÔCT „3Ø¡lÈ¡‚6˜Ÿ8ÌàC€„8Ü°bKY(¡„C)ä‘H"“¹D~HôƒI°'é @JdäËLpÉ¥}`úÒ„vJÄ=0 HñCˆ€ƒ4¾„À„v† ¦O@ÑE$QB+ ðG AÄÃB M@ ©£”:Êç~.!Dü‘"ܨMI–jê©L|W„ DI  À¬´Öjë­¸Þ*€;tcltk2/inst/tklibs/ttktheme_keramik/keramik/arrowright-n.gif0000644000176200001440000000042214656355210024014 0ustar liggesusersGIF89a„sss”””ÓÓÓÔÔÔÕÕÕÛÛÛÞÞÞàààáááãããäääåååçççèèèéééíííîîîïïïðððóóóôôôõõõööö÷÷÷ùùùûûûýýýÿÿÿÿÿÿÿÿÿÿÿÿ!þCreated with The GIMP!ù ,v ŒdiŠÒ¢®¬ÚHc"Ïô¬Pã£ïü.m£‹px3\ Ãlf&† T®Ð,T˜¹DF“°V+¬|’ôX[±@FiÉJ©PÞˆ~‰H"#-*P+ *#Š‹Œ #”•––p›œ"&¢$!;tcltk2/inst/tklibs/ttktheme_keramik/keramik/tbar-n.gif0000644000176200001440000000035614656355210022562 0ustar liggesusersGIF89a„üüüûûûùùùøøø÷÷÷öööõõõôôôóóóòòòñññðððïïïîîîíííìììëëëêêêéééèèèçççæææåååäääâââáááàààãããýýýúúúúúúúúú!ù ,k Žc`ž¦ ®êà¾.!ÏDaÜø}ìü$À PA,*Œ¤’Ñh:›Ž‡tú€X¯ÖˆdË•L¾à/¥B.W,è4úÂn³1ð8%1='6C+;I.?O2DV5H[8L`p0Ñ`‡Ç AI²dÉ$ 6:ÐÁ²¥K—&c’4"Bƒ‰>rêܹ“ˆÏŸ@61ñ„#H“*UŠ°©A)*H°ˆ¥ªÕ«WµhÝÊ•ë+ZH¨B¶¬Y³\Òª]»vK&.&ð˜K·nÝ"xóêÕûä “%*L˜p†Ãˆ'¶€áÂ;tcltk2/inst/tklibs/ttktheme_keramik/keramik/hslider-t.gif0000644000176200001440000000110314656355210023261 0ustar liggesusersGIF89aÆD-./334567??AABCHIKMNOOPRSTUTTVZ[]]]`_`bbceefhpqsqru…†ˆ’’’œ¡žŸ£ ¢¥¢¢¢£££¤¤¤¦§«ªªª­­­°°°´¶º·¹½½¿Ã¿ÀÅÀÁÆÁÃÇÂÃÈÂÄÈÃÅÉÄÆÊÅÇËÆÈÌÇÉÍÈÊÎÉËÏÊËÐÊÌÐËÌÑËÍÑÌÍÒÌÎÒÎÐÔÐÒÖÑÓ×ÓÔØÓÕÙÔÖÚÕÖÛÖ×Û×ÙÝØÚÞßáäáãæáãçèéíéëîéëïïñôñóöÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!ù , €‚ƒ„…†‡ˆ‰Š(Œ6Ž60.(„96ÆÇ7$%' &%!-8ÕÖ6Ë Î%Ã#3áâ:,( ÎÞ&1îï<2.‚%&üý)Hà0(A@  …8`°@±"E ) ;tcltk2/inst/tklibs/ttktheme_keramik/keramik/hsb-h.gif0000644000176200001440000000035114656355210022373 0ustar liggesusersGIF87a„———’’’vvvÿÿÿÞÞÞßßßàààäääãããïïïñññûûûôôôúúúþþþøøøùùùèèèêêêéééÓÓÓÒÒÒÑÑÑÏÏÏÖÖÖÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ,n ŒdižÂ ®lÛiaGmß72ÀC‚(‹ p8dìR —ò•r,ŸÇªäM¬VëâAVŽ°xÌ”J#è´í`8yƒ…dN¯Û%Ñø}/™P¢„…†…QŽG”•–—˜"'››!;tcltk2/inst/tklibs/ttktheme_keramik/keramik/mbut-arrow-n.gif0000644000176200001440000000007514656355210023727 0ustar liggesusersGIF89a €ÿÿÿ!ù ,  ŽËíïx’¦&ïÊëx@›S;tcltk2/inst/tklibs/ttktheme_keramik/keramik/button-s.gif0000644000176200001440000000153314656355210023150 0ustar liggesusersGIF89aÆîîîõõõúúúüüüïïïôôô÷÷÷øøøþþþóóóëëëèèèåååãããáááðððçççäääÐÐÐÖÖÖÛÛÛÞÞÞÝÝÝàààæææÓÓÓÙÙÙÕÕÕÚÚÚÜÜÜØØØÏÏÏÇÇÇÍÍÍÔÔÔ½½½ÈÈȳ³³×××ÄÄÄÌÌÌËË˦¦¦ÀÀÀÉÉÉ™™™ÆÆÆÅÅż¼¼†††»»»ííívvvºººñññlll¹¹¹ÃÃÃdddÂÂÂýýýööö]]]UUUMMMFFFRRRÊÊÊIIIooo¬¬¬ÎÎÎùùù­­­WWW¶¶¶ßßßNNN„„„‰‰‰EEE¨¨¨°°°GGGfffaaa666+++444QQQƒƒƒúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúúú!ù ,þ€‡ˆ‰‰‚ šš  š ®® ­® «¯¾ÄºËÒÐÊ !"ÕãäãÐ!ª #$áåóãÞð#%&!'(ôô&¤8ÂD H¬`1A˜Ã‡'°XAb‚Š\Œà¡£ÇM°s±¡Å‹ 0bÀ°° ¥Ë—-=¤„‘á… ”3`T Á³§Ož`äÌ £F†6N\¸Á´©S¦žÈPÇÑ:ØʵëÖ :rLű㨠4 êÁ¶í¹>.ðHšaÇByhõ! ¯ß¾>0БSÄ GœH»¶-Û·>œQH (xÀ À±ç¸àBC!2¸€Q Ÿa¨/!Cˆì#ÀõãE> ˜øðÁDŠ"FŽx˜€Ä‚’˜>½À‚6LРd “ H<˜gb•ƒóçc=Xà I'Oþ@‰"%„îsØ¿ßBƒÿLAE”`ÅX$¨à‚ f¡Å‚;tcltk2/inst/tklibs/ttktheme_keramik/keramik/vsb-n.gif0000644000176200001440000000062514656355210022423 0ustar liggesusersGIF89a¥"&=f&>g&>h'>h'?j-Ep1Is1It7Nx7OyEObFQc@Á4ðSDaÂL:ùäQòHå¤E ?˜ÅTÔ@ .¸™æxVသzâé'ž ´R (PPƒW`B)´Ð13ú™…“Núç¥ \ At…[ PàÁ¿ˆÂD«®*J(Ã\P +@Ä\t!C QLů+ì°Ä;¬$ÛS|! aˆ1Æ´ÔVkíµØ^KFf;tcltk2/inst/tklibs/ttktheme_keramik/keramik/indicator-o.gif0000644000176200001440000000010014656355210023572 0ustar liggesusersGIF89a ¡ÇÇÇÿÿÿÿÿÿ!ù , Œ¢+Æë^ X;e–ñ¡;tcltk2/inst/tklibs/ttktheme_keramik/keramik/spinup-p.gif0000644000176200001440000000027614656355210023153 0ustar liggesusersGIF89a„¥¥¥­­­µµµÂÂÂÅÅÅÊÊÊÐÐÐÑÑÑÓÓÓÙÙÙÛÛÛÜÜÜâââãããäääåååæææèèèéééëëëìììîîîÿÿÿÊÊÊÊÊÊÊÊÊÊÊÊÊÊÊÊÊÊÊÊÊÊÊÊÊÊÊ!ù ,;à÷U%9Œ#Q¤(V¤…¡@Så~” K`Àí" À‘Ý!`ZˆÇÎq°zxL.‹B;tcltk2/inst/tklibs/ttktheme_keramik/keramik/hsb-a.gif0000644000176200001440000000055614656355210022373 0ustar liggesusersGIF87a¥———‰‰‰vvvÿÿÿ‡‡‡ÈÈÈÇÇÇÉÉÉÎÎÎÍÍÍÚÚÚÜÜÜæææßßßíííðððñññõõõüüüåååòòòøøøîîîéééãããìììëëëäääÒÒÒÔÔÔÓÓÓ½½½¼¼¼»»»¹¹¹¿¿¿ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ,“@@`H,‚rÉl6 ÉBÁp¨Z¯WÄ:H ‹°xÙä”T>xc+ˆàO@EG'l) ~RTPf™c xAx„Â+LAEA|`]p€,TÐgŸiøB \À W`‘…V± lPŒ”Vª„—^Z馜:0è 8`„Zlñ]x1PÀj°Æ*무ÊZA¸~ðaH‚‚c!ì°Äkì±Æ–aÆ‚;tcltk2/inst/tklibs/ttktheme_keramik/keramik/hsb-n.gif0000644000176200001440000000062114656355210022401 0ustar liggesusersGIF89a¥"&=f&>g&>h'>h'?j-Ep1Is1It7Nx7OyEObFQcïùxê!†‡‡ƒ„€‘’‘Ž€žŸŸ†€©ª«h^! µ¶·¸€³¸¼µ € ÅÆÇÅ€ÎÏÐÑu^ÕÖ×QGÚGA;tcltk2/inst/tklibs/ttktheme_keramik/keramik/vslider-n.gif0000644000176200001440000000111314656355210023272 0ustar liggesusersGIF89a Æ[    ! #%')'-"1 6#;$=&@!%/ &1!(4*G+H#+7(,3%-<.M/O1R'0@ 3U 4W*3E!6Z*5G*5K%7X"8]#9_#9`$:b$;b%g&>h'>h1=T'?i'@k(@k(Am)Bn)Bo)Cp*Cq*Dr,Hx/Hv:G_KKMINVPPP:SJ\{OfXfklnlmoZp˜ftŒaxŸuvwpy‡yyzf|£}ƒsˆ­x±‘’‘‘‘”””—¦…™»™šŸ¥¯®®®¬°¸ÀÀÀÁÁÂÄÄÄËËËÌÌÌÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!þCreated with The GIMP!ù , €ZWG9-! 7ÐÙâ*VP'6EàÒ/)JYZS@"0Xà@;¤hÑ;tcltk2/inst/tklibs/ttktheme_keramik/keramik/progress-v.gif0000644000176200001440000000131114656355210023476 0ustar liggesusersGIF89a#Æk%.'0(2+6#-7!.:$0<$1>%1='6C+;I.?O2DV5H[8L`>>???CCCEEEJJJQQQRRRXXX^^^ßßßÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!þCreated with The GIMP!ù ,f`p `žÀ1 F ’ä0ô¢²î˜Äs}·¯ŒÆ°­€ºGd¹4â‚Jfĉ„I§¿œUJÕ^¥GmâÉB¯Ýâ4҇¡ÁŽ8Ä€P5(ˆDq.‰ˆ‰ =.‘’“!;tcltk2/inst/tklibs/ttktheme_keramik/keramik/tree-p.gif0000644000176200001440000000126014656355210022566 0ustar liggesusersGIF89a Æq56767899:=>?AACEEGHIJMNOQRTWWY\]_abdghjmnpqruvwz|}€‚ƒƒƒ††ˆ‹Œ‘””•™˜šœ¡ ¢¥¡£¦¢£§£¤¨¤¥©¦§«¦¨«¦¨¬§©¬¨ª­©«®ª«¯«¬°«­±¬­±¬®²­®²­¯³®¯³®°´¯±µ°²µ±²¶²³·²´¸³µ¸³µ¹µ·»¶·»¶¸»¶¸¼·¹½¸¹½¸º½¹»¾¹»¿º»¿»¼À¼½Á¼¾Â½¾Â½¿Â½¿Ã¾¿Ã¾ÀÄ¿ÀÄÀÁÅÀÂÆÁÂÄÁÂÆÁÃÇÂÃÇÃÄÈÄÅÉÅÆÊÆÇËÆÈÌÇÈÌÇÉÌÈÉÍÈÊÍÈÊÎÉËÎÉËÏÊËÏÊÌÐËÌÐËÍÑÌÎÑÌÎÒÎÐÓÑÒÖÓÕÙÔÕÙÔÖÙÕÖÚÙÛÞÝßâáãæâãçåçêæçëçéìêëïìíññòöóôøôõøÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!ù , þ€‚ƒ‚†==>H\\511FGRal˜l:.,MK]hp£pBœEG^jo­oF,*FAXkn¸n?'(@=TgmÃm;#'=9LeiÎi2!%82?dfÙf,# 3)6`bäb&" -%/[Ž\$! +$,UQùQ"! '!T8Bpˆˆ q‚‡H@1¢Å8}˜èb‚Š1¤0ÊD…‡X°À‘ŠS(1B„¨Ð"Æ/Z²jéQB„7œŒ±BÖŠ’(.qr%ŠŽ·:ÀLy‚!ƒÝ»x3$ ;tcltk2/inst/tklibs/ttktheme_keramik/keramik/tab-h.gif0000644000176200001440000000154714656355210022375 0ustar liggesusersGIF89a ÆM¶¶¶uuuNNN<<<;;;ŒŒŒSSS®®®àààóóóßßßµµµ[[[ÑÑÑçççüüüþþþyyy©©©ÜÜÜùùùUUUÐÐÐÚÚÚ×××øøøýýýQQQÒÒÒõõõVVVÌÌÌÍÍÍòòò\\\ÔÔÔÇÇÇÉÉÉíííöööaaaÅÅÅÆÆÆèèègggÏÏÏÂÂÂÄÄÄðððkkkÎÎÎÁÁÁÃÃÃáááëëëqqqÀÀÀêêêwww¿¿¿|||âââ¾¾¾ÙÙÙÛÛÛÖÖÖÝÝ݇‡‡———ØØØ   ÕÕÕ¨¨¨ÓÓÓÊÊÊËËËÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!ù , þ€‚ƒ„…†‡ˆ‰Š‹ˆ’“”„ ¡¢£ ‚ ²³´° ÂÃÄÃÅÓáâãâÞ !µñ! "#$%&' ¤pÂD #DüAÑ …Š "Jœ(q…Š PüaÑÂÅ 0BŠ)ÒÁ -Xlìø‘¤Ë&QªŒ!c&lèÜÉÓ†‰4fȈñç† 3äXÁ´©Ó9ÌÀ!ãÆ v̘°¢†×¯`k¬˜0cx|ØcBRÅp{LÀ±ã´|ìø¡ˆß¿€(ø±Ã‡Ý´Yw‚¡±ãÇ„Ùaö.Ä‹!k–L„eÌŒ5?æ\1åÌ¢“ölZqèÔ‘'—:ˆíÛ¸Ë1ä‘£8‚ÉM|8ªD|N<·qäŠ4ä‚‘ëس¹Äfƒ"Ž QñBø„óèÓOþB’#’ ù b±úû’U|@’äÏ‚J,¡Þh 7H¨D »¤À„ ´ á„VØ€L¤ðG ;tcltk2/inst/tklibs/ttktheme_keramik/keramik/mbut-d.gif0000644000176200001440000000204114656355210022560 0ustar liggesusersGIF89a,ÆèèèçççæææäääåååêêêãããàààÞÞÞÝÝÝÜÜÜÛÛÛáááÙÙÙ×××ÚÚÚØØØéééßßßÕÕÕÒÒÒÐÐÐÔÔÔÍÍÍÅÅÅÓÓÓÊÊÊÑÑÑÌÌÌ»»»ÆÆÆ°°°ÁÁÁÉÉÉ¥¥¥½½½ÇÇÇââ☘˜ÄÄĺººÃÃÃ………¹¹¹}}}¼¼¼µµµuuu¸¸¸ÖÖÖ¯¯¯kkk···ÀÀÀ©©©ccc¿¿¿£££[[[ŸŸŸTTTLLLEEEQQQÈÈÈ¢¢¢IIInnnªªªËËË«««WWW¶¶¶MMM„„„‰‰‰DDD¦¦¦®®®FFFeee³³³```555***444PPP‚‚‚ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!ù ,,þ€†‡ˆ‰Š‹Œ‚ ›œžŸ £ œ–±²³´µ³ ¼   ÈÉÊËÌÌ’Ã ßàâäáæáÇ Ö ¬ÍÈøøöÍ 2@ÀÐÁ‡ ^Ù“€!C~Ë$%Ðp°A‡4€Ð€ÀÀF„ ÉHÑ BlœðAD#H((áÑV7oÚªu²„#¼Ô¸ßþ9(a~€ÐP>üà€:¤ÐàBà„ûhÁ :hàÀ@ÌPÁ +HÃË5ÔXcàˆ£<öx Ì8DBd€äA‘ë7ÄO>Ùäz (LE1CG\`A0 ¬'Âgž9¥z H¶8€DJüpÄ l@Ád’2Ê ¨Ÿ„úÙ&,Ð@K0ñGN<¡"5øhé¥=†§\PD!$SPQ…¤–jꩨ¦ŠêXd!H ;tcltk2/inst/tklibs/ttktheme_keramik/keramik/vsb-a.gif0000644000176200001440000000056514656355210022411 0ustar liggesusersGIF87a¥‰‰‰‡‡‡ÿÿÿÎÎÎæææüüüõõõñññðððíííÒÒÒÓÓÓ¿¿¿½½½ÉÉÉÜÜÜøøøòòòîîîÔÔÔ¹¹¹ååå»»»ëëëäääéééÇÇÇÚÚÚ¼¼¼ÈÈÈìììÍÍÍßßßããã———vvvÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ,š@@`H,rÉ\‚¡`8 Å‚Ñx&$‘d'”.|0D’ŠBaQ‡ÈArÁÌë^le ~tv‚xe†‰ƒ‡€k‹’Žˆ‘“›—š–y˜” ™•w¤¡ªŠ¬©§y{}žPdpr ‰ z À Î!M×O"#ÜÝÞÞ"A;tcltk2/inst/tklibs/ttktheme_keramik/keramik/spindown-p.gif0000644000176200001440000000031714656355210023472 0ustar liggesusersGIF89a„ ¥¥¥§§§«««­­­µµµ···ÂÂÂÅÅÅÉÉÉÊÊÊÐÐÐÑÑÑÓÓÓÖÖÖÙÙÙÚÚÚÛÛÛÜÜÜâââãããäääåååæææçççèèèêêêëëëìììîîîÿÿÿÊÊÊÊÊÊ!ù ,Là÷eUÔ,ÊÒDU&Š×ƒB Ès½µtÀ`g1áUa‡À¨ð0‘ 8D0¼Åat‡EÃãh,EBsÊf EBÁh8ïO;tcltk2/inst/tklibs/ttktheme_keramik/keramik/arrowdown-n.gif0000644000176200001440000000042114656355210023645 0ustar liggesusersGIF89a„sss«««ÔÔÔÕÕÕ×××ÞÞÞàààáááäääåååçççèèèéééëëëíííîîîïïïðððñññóóóôôôööö÷÷÷ùùùÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ!þCreated with The GIMP!ù ,u ŒdYŠÉ¢2ŒêªÇ˜$΄URíG „ÃrËE‰ÁálXP(r@`"œQi²*»>³S.Л„­å,ÕÚH¶ìoôÜeX.Q D±–O LB; # ,—*"&¡#!;tcltk2/inst/tklibs/ttktheme_keramik/keramik/check-c.gif0000644000176200001440000000066214656355210022674 0ustar liggesusersGIF89a¥5---444<<ø=L± %s vRƒa~B4ƒ†V‰[ …40’ .4–˜/ ’-Ÿ¡ŽR*’,Ÿ†#’(4{S{’!#$+&#%''$ ’ "!ÂÉ##’ àáâá’êëìpCôõödFûûA;tcltk2/inst/tklibs/ttktheme_keramik/keramik/tbar-p.gif0000644000176200001440000000163714656355210022567 0ustar liggesusersGIF89aç  !!!"""###$$$%%%&&&'''((()))***+++,,,---...///000111222333444555666777888999:::;;;<<<===>>>???@@@AAABBBCCCDDDEEEFFFGGGHHHIIIJJJKKKLLLMMMNNNOOOPPPQQQRRRSSSTTTUUUVVVWWWXXXYYYZZZ[[[\\\]]]^^^___```aaabbbcccdddeeefffggghhhiiijjjkkklllmmmnnnooopppqqqrrrssstttuuuvvvwwwxxxyyyzzz{{{|||}}}~~~€€€‚‚‚ƒƒƒ„„„………†††‡‡‡ˆˆˆ‰‰‰ŠŠŠ‹‹‹ŒŒŒŽŽŽ‘‘‘’’’“““”””•••–––———˜˜˜™™™ššš›››œœœžžžŸŸŸ   ¡¡¡¢¢¢£££¤¤¤¥¥¥¦¦¦§§§¨¨¨©©©ªªª«««¬¬¬­­­®®®¯¯¯°°°±±±²²²³³³´´´µµµ¶¶¶···¸¸¸¹¹¹ººº»»»¼¼¼½½½¾¾¾¿¿¿ÀÀÀÁÁÁÂÂÂÃÃÃÄÄÄÅÅÅÆÆÆÇÇÇÈÈÈÉÉÉÊÊÊËËËÌÌÌÍÍÍÎÎÎÏÏÏÐÐÐÑÑÑÒÒÒÓÓÓÔÔÔÕÕÕÖÖÖ×××ØØØÙÙÙÚÚÚÛÛÛÜÜÜÝÝÝÞÞÞßßßàààáááâââãããäääåååæææçççèèèéééêêêëëëìììíííîîîïïïðððñññòòòóóóôôôõõõööö÷÷÷øøøùùùúúúûûûüüüýýýþþþÿÿÿ!ù þ,|¥8°Y¶ƒ¥lkÇá?… JÑÆ®bŇÔÊiÔˆq#G)Ôȉ‰q$I&É•4ÙÑãÃlèbÆ|)s¦B‹oâ|ÈÍOŸÁÍ:4(Ñ¢RÀÑ[º4(Ó¦RÊÝ›:õ¡Tª÷šÃÇ•«Ö®^¥lû]¾³g­þ[Ë6 ;tcltk2/inst/tklibs/ttktheme_keramik/keramik.tcl0000644000176200001440000003305415017041713021405 0ustar liggesusers# keramik.tcl - # # A sample pixmap theme for the tile package. # # Copyright (c) 2004 Googie # Copyright (c) 2004 Pat Thoyts # # $Id: keramik.tcl,v 1.12 2009/01/24 13:26:16 sbron Exp $ # Also works with Tcl/Tk 9.0 package require Tk; #package require Tk 8.4; # minimum version for Tile package require tile 0.8.0; # depends upon tile 0.8.0 namespace eval ttk { namespace eval theme { namespace eval keramik { variable version 0.6.1 } namespace eval keramik_alt { variable version 0.6.1 } } } namespace eval ttk::theme::keramik { variable colors array set colors { -frame "#cccccc" -lighter "#cccccc" -window "#ffffff" -selectbg "#0a5f89" -selectfg "#ffffff" -disabledfg "#aaaaaa" } variable hover hover # Need a two-step check as 8.4 doesn't understand beta version numbers if {![package vsatisfies [package present Ttk] 8.6] || \ ![package vsatisfies [package present Ttk] 8.6b1]} { # The hover state is not supported prior to 8.6b1 set hover active } proc LoadImages {imgdir} { variable I foreach file [glob -directory $imgdir *.gif] { set img [file tail [file rootname $file]] set I($img) [image create photo -file $file -format gif89] } } LoadImages [file join [file dirname [info script]] keramik] ttk::style theme create keramik -parent alt -settings { # ----------------------------------------------------------------- # Theme defaults # ttk::style configure . \ -borderwidth 1 \ -background $colors(-frame) \ -troughcolor $colors(-lighter) \ -selectbackground $colors(-selectbg) \ -selectforeground $colors(-selectfg) \ -fieldbackground $colors(-window) \ -font TkDefaultFont \ ; ttk::style map . -foreground [list disabled $colors(-disabledfg)] # ----------------------------------------------------------------- # Button elements # - the button has a large rounded border and needs a bit of # horizontal padding. # - the checkbutton and radiobutton have the focus drawn around # the whole widget - hence the new layouts. # ttk::style layout TButton { Button.background Button.button -children { Button.focus -children { Button.label } } } ttk::style layout Toolbutton { Toolbutton.background Toolbutton.button -children { Toolbutton.focus -children { Toolbutton.label } } } ttk::style element create button image [list $I(button-n) \ {pressed !disabled} $I(button-p) \ selected $I(button-s) \ {active !disabled} $I(button-h) \ disabled $I(button-d)] \ -border {8 6 8 16} -padding {6 6} -sticky news ttk::style configure TButton -padding {10 6} -anchor center ttk::style element create Toolbutton.button image [list $I(tbar-n) \ {pressed !disabled} $I(tbar-p) \ selected $I(tbar-p) \ {active !disabled} $I(tbar-a)] \ -border {2 9 2 18} -padding {2 2} -sticky news ttk::style configure Toolbutton -anchor center ttk::style element create Checkbutton.indicator \ image [list $I(check-u) selected $I(check-c)] \ -width 20 -sticky w ttk::style element create Radiobutton.indicator \ image [list $I(radio-u) selected $I(radio-c)] \ -width 20 -sticky w # The layout for the menubutton is modified to have a button element # drawn on top of the background. This means we can have transparent # pixels in the button element. Also, the pixmap has a special # region on the right for the arrow. So we draw the indicator as a # sibling element to the button, and draw it after (ie on top of) the # button image. ttk::style layout TMenubutton { Menubutton.background Menubutton.button -children { Menubutton.focus -children { Menubutton.padding -children { Menubutton.label -side left -expand true } } } Menubutton.indicator -side right } ttk::style element create Menubutton.button image [list $I(mbut-n) \ {active !disabled} $I(mbut-a) \ {pressed !disabled} $I(mbut-a) \ {disabled} $I(mbut-d)] \ -border {7 10 29 15} -padding {7 4 29 4} -sticky news ttk::style element create Menubutton.indicator image $I(mbut-arrow-n) \ -width 11 -sticky w -padding {0 0 18 0} ttk::style element create Combobox.field image [list $I(cbox-n) \ [list readonly disabled] $I(mbut-d) \ [list readonly $hover] $I(mbut-a) \ [list readonly] $I(mbut-n) \ [list disabled] $I(cbox-d) \ [list $hover] $I(cbox-a) \ ] -border {9 10 32 15} -padding {9 4 8 4} -sticky news ttk::style element create Combobox.downarrow image $I(mbut-arrow-n) \ -width 11 -sticky e -border {22 0 0 0} # ----------------------------------------------------------------- # Scrollbars, scale and progress elements # - the scrollbar has three arrow buttons, two at the bottom and # one at the top. # ttk::style layout Vertical.TScrollbar { Scrollbar.background Vertical.Scrollbar.trough -children { Scrollbar.uparrow -side top Scrollbar.downarrow -side bottom Scrollbar.uparrow -side bottom Vertical.Scrollbar.thumb -side top -expand true -sticky ns } } ttk::style layout Horizontal.TScrollbar { Scrollbar.background Horizontal.Scrollbar.trough -children { Scrollbar.leftarrow -side left Scrollbar.rightarrow -side right Scrollbar.leftarrow -side right Horizontal.Scrollbar.thumb -side left -expand true -sticky we } } ttk::style element create Horizontal.Scrollbar.thumb \ image [list $I(hsb-n) {pressed !disabled} $I(hsb-p)] \ -border {6 4} -width 15 -height 16 -sticky news ttk::style element create Horizontal.Scrollbar.trough image $I(hsb-t) ttk::style element create Vertical.Scrollbar.thumb \ image [list $I(vsb-n) {pressed !disabled} $I(vsb-p)] \ -border {4 6} -width 16 -height 15 -sticky news ttk::style element create Vertical.Scrollbar.trough image $I(vsb-t) ttk::style element create Horizontal.Scale.slider image $I(hslider-n) \ -border 3 ttk::style element create Horizontal.Scale.trough image $I(hslider-t) \ -border {6 1 7 0} -padding 0 -sticky wes ttk::style element create Vertical.Scale.slider image $I(vslider-n) \ -border 3 ttk::style element create Vertical.Scale.trough image $I(vslider-t) \ -border {1 6 0 7} -padding 0 -sticky nes ttk::style element create Horizontal.Progressbar.pbar \ image $I(progress-h) -border {1 1 6} ttk::style element create Vertical.Progressbar.pbar \ image $I(progress-v) -border {1 6 1 1} ttk::style element create uparrow \ image [list $I(arrowup-n) {pressed !disabled} $I(arrowup-p)] ttk::style element create downarrow \ image [list $I(arrowdown-n) {pressed !disabled} $I(arrowdown-p)] ttk::style element create rightarrow \ image [list $I(arrowright-n) {pressed !disabled} $I(arrowright-p)] ttk::style element create leftarrow \ image [list $I(arrowleft-n) {pressed !disabled} $I(arrowleft-p)] # Treeview elements # ttk::style element create Treeheading.cell \ image [list $I(tree-n) pressed $I(tree-p)] \ -border {5 15 5 8} -padding 12 -sticky ewns # ----------------------------------------------------------------- # Notebook elements # ttk::style element create tab \ image [list $I(tab-n) selected $I(tab-p) active $I(tab-p)] \ -border {6 6 6 4} -padding {6 3} -height 12 ttk::style configure TNotebook -tabmargins {0 3 0 0} ttk::style map TNotebook.Tab \ -expand [list selected {0 3 2 2} !selected {0 0 2}] ## Settings. # ttk::style configure TLabelframe -borderwidth 2 -relief groove if {[package vsatisfies [package present Ttk] 8.6] && \ [package vsatisfies [package present Ttk] 8.6b1]} { # Spinbox (only available since 8.6b1) ttk::style layout TSpinbox { Spinbox.field -side top -sticky we -children { Spinbox.arrows -side right -sticky ns -children { null -side right -sticky {} -children { Spinbox.uparrow -side top -sticky w Spinbox.downarrow -side bottom -sticky w } } Spinbox.padding -sticky nswe -children { Spinbox.textarea -sticky nswe } } } ttk::style element create Spinbox.arrows image $I(spinbox-a) \ -border {0 9} -padding 0 ttk::style element create Spinbox.uparrow \ image [list $I(spinup-n) {pressed !disabled} $I(spinup-p)] ttk::style element create Spinbox.downarrow \ image [list $I(spindown-n) {pressed !disabled} $I(spindown-p)] # Treeview ttk::style configure Treeview -background $colors(-window) ttk::style map Treeview \ -background [list selected $colors(-selectbg)] \ -foreground [list selected $colors(-selectfg)] } else { # Treeview ttk::style configure Treeview.Row -background $colors(-window) ttk::style configure Row -background $colors(-window) ttk::style configure Cell -background $colors(-window) ttk::style map Row \ -background [list selected $colors(-selectbg)] \ -foreground [list selected $colors(-selectfg)] ttk::style map Cell \ -background [list selected $colors(-selectbg)] \ -foreground [list selected $colors(-selectfg)] ttk::style map Item \ -background [list selected $colors(-selectbg)] \ -foreground [list selected $colors(-selectfg)] } } } namespace eval ttk::theme::keramik_alt { variable colors array set colors { -frame "#cccccc" -lighter "#cccccc" -window "#ffffff" -selectbg "#0a5f89" -selectfg "#ffffff" -disabledfg "#aaaaaa" } proc LoadImages {imgdir} { variable I foreach file [glob -directory $imgdir *.gif] { set img [file tail [file rootname $file]] set I($img) [image create photo -file $file -format gif89] } } LoadImages [file join [file dirname [info script]] keramik_alt] ttk::style theme create keramik_alt -parent keramik -settings { # ----------------------------------------------------------------- # Theme defaults # ttk::style configure . \ -borderwidth 1 \ -background $colors(-frame) \ -troughcolor $colors(-lighter) \ -selectbackground $colors(-selectbg) \ -selectforeground $colors(-selectfg) \ -fieldbackground $colors(-window) \ -font TkDefaultFont \ ; ttk::style map . -foreground [list disabled $colors(-disabledfg)] # The alternative keramik theme doesn't have the conspicuous # highlighted scrollbars of the main keramik theme. # ttk::style element create Vertical.Scrollbar.thumb \ image [list $I(vsb-a) {pressed !disabled} $I(vsb-h)] \ -border {4 6} -width 16 -height 15 -sticky news ttk::style element create Horizontal.Scrollbar.thumb \ image [list $I(hsb-a) {pressed !disabled} $I(hsb-h)] \ -border {6 4} -width 15 -height 16 -sticky news # Repeat the settings because they don't seem to be copied from the # parent theme. # ttk::style configure TButton -padding {10 6} -anchor center ttk::style configure Toolbutton -anchor center ttk::style configure TNotebook -tabmargins {0 3 0 0} ttk::style map TNotebook.Tab \ -expand [list selected {0 3 2 2} !selected {0 0 2}] ttk::style configure TLabelframe -borderwidth 2 -relief groove if {[package vsatisfies [package present Ttk] 8.6] && \ [package vsatisfies [package present Ttk] 8.6b1]} { # Treeview ttk::style configure Treeview -background $colors(-window) ttk::style map Treeview \ -background [list selected $colors(-selectbg)] \ -foreground [list selected $colors(-selectfg)] } else { ttk::style configure Treeview -padding 0 ttk::style configure Treeview.Row -background $colors(-window) ttk::style configure Row -background $colors(-window) ttk::style configure Cell -background $colors(-window) ttk::style map Row \ -background [list selected $colors(-selectbg)] \ -foreground [list selected $colors(-selectfg)] ttk::style map Cell \ -background [list selected $colors(-selectbg)] \ -foreground [list selected $colors(-selectfg)] ttk::style map Item \ -background [list selected $colors(-selectbg)] \ -foreground [list selected $colors(-selectfg)] } } } package provide ttk::theme::keramik $::ttk::theme::keramik::version package provide ttk::theme::keramik_alt $::ttk::theme::keramik_alt::version tcltk2/inst/tklibs/widget3.2/0000755000176200001440000000000015017041713015427 5ustar liggesuserstcltk2/inst/tklibs/widget3.2/mentry.tcl0000644000176200001440000002170415017041713017455 0ustar liggesusers# -*- tcl -*- # # mentry.tcl - # # MenuEntry widget # # RCS: @(#) $Id: mentry.tcl,v 1.7 2010/06/01 18:06:52 hobbs Exp $ # # Creation and Options - widget::menuentry $path ... # -menu -default "" ; menu to associate with entry # -image -default "default" # All other options to entry # # Methods # All other methods to entry # # Bindings # NONE # if 0 { # Samples package require widget::menuentry set me [widget::menuentry .me] set menu [menu .me.menu -tearoff 0] $menu add radiobutton -label "Name" -variable foo -value name $menu add radiobutton -label "Abstract" -variable foo -value abstract $menu add separator $menu add radiobutton -label "Name and Abstract" \ -variable foo -value [list name abstract] $me configure -menu $menu pack $me -fill x -expand 1 -padx 4 -pady 4 } ### package require widget namespace eval ::widget { # PNG version has partial alpha transparency for better look variable menuentry_pngdata { iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAACXBIWXMAAAs6 AAALOgFkf1cNAAACkklEQVR4nHWSXUhTYRjHdxnRVQTeCElXp7vS6BCZFGlO nc2vbdrccrbhR9IKI7KOXzQniikzUvyIlNoHrZgXmYrbas6cg3keKFKoqHiC VowgeC6C4PB24RmlRy/+Nw/v7/c+/5dXxRhTMcZUoqeWF73mgOi1pMBnlURP vZSYNqVWJw2BlZFKPn1uezZhr8kGPktS9JjFxPQFIf7AwK1O6LnVcZ0QGzeI sVFDcslVZttRIHpqefBZkmuPjU5AOgxIVYBkB6QWQCoFpENRV5kz6qpMhvs0 ik1Uax5zYM1tFgGJA6QmQGoDpBuAdB2QrgGSEZCyIoNaMdSnCeywQV0qMVUj AFIFIN2U4VYZbgGkZkDKDzlLhHBfaUohAG+9FJ80cIB0+b9b0xWaAKkBkIyL 3Wou3K+VlBXcFik2puPkg3ZAuiLLGuWZFZAM8x0FXMipUQriD42p2GiVAEhq GWyWYRsgXQKkOkDKm7tdIMx3FiorrIzpAysjOhGQsgBJL4NWQLLIsBaQMhe6 i36/aDsbVwiiw+X88n1dMjKkdQLSQUA6A0gGQNIBUi4gZUaHdX/e+O0s3Hqa zdhzaxQf6dXAedvSUFky3F8qBh1FwkLnOW6uvYCbu5UvRAYqpPXnbexrYox9 Wr7Lgne07GnjiYwtAsaYKthTzAd7igNBpyYVcmqkoKNEmuso/LXYrWEfXvay 7+8esR8bbvZ+sYv5rackX/3xjC2C3TJzNc8UGaxmn18PseTbKfYldo/FJyys V8199FzM2bu5hkrFtud/ybPmk6ago5xtzLaz9dlOFnXpmb+B/+k2Z+/79xi7 wOk8sfEmd20OW+hSM7+V/+Y2Zx9QVNgNTsdbd2z/RPURh9t8dE969hckF6c1 n3C8ywAAAABJRU5ErkJggg== } variable menuentry_gifdata { R0lGODlhEAAQAPcAAAQEBIREJJpaL6RaL6RkL6RkOq9kOq9vOrpvRLp6RLqE T7qPT8SPT8SaT8SaWsSaZM+kWs+kZM+vb8/k79qvetq6etq6hNrEj+TPmuTP pOTapPr6+gAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAP///yH5BAEAAP8ALAAAAAAQABAAQAh4AP8JhBChIAQH AhMKdIBQYcIECRRGcOhQAcWLDi5kuPAggMAIECgyYOBw4kWBFh0yWKCQAQUM F1ImBECT4oAEBiSGTMiQIoSdImX+M3mSJc+TAiMqdEDSoQMJCC4qmKoggQIL GjRYyCmQpleFCipUcMC160kBCQMCADs= } } proc ::widget::createMenuEntryLayout {} { variable MENUENTRY if {[info exists MENUENTRY]} { return } set MENUENTRY 1 variable menuentry_pngdata variable menuentry_gifdata set img ::widget::img_menuentry if {[package provide img::png] != ""} { image create photo $img -format PNG -data $menuentry_pngdata } else { image create photo $img -format GIF -data $menuentry_gifdata } namespace eval ::ttk [list set img $img] ; # namespace resolved namespace eval ::ttk { # Create -padding for space on left and right of icon set pad [expr {[image width $img] + 4}] style theme settings "default" { style layout MenuEntry { Entry.field -children { MenuEntry.icon -side left Entry.padding -children { Entry.textarea } } } # center icon in padded cell style element create MenuEntry.icon image $img \ -sticky "" -padding [list $pad 0 0 0] } if 0 { # Some mappings would be required per-theme to adapt to theme # changes foreach theme [style theme names] { style theme settings $theme { # Could have disabled, pressed, ... state images #style map MenuEntry -image [list disabled $img] } } } } } snit::widgetadaptor widget::menuentry { delegate option * to hull delegate method * to hull option -image -default "default" -configuremethod C-image option -menu -default "" -configuremethod C-menu constructor args { ::widget::createMenuEntryLayout installhull using ttk::entry -style MenuEntry bindtags $win [linsert [bindtags $win] 1 TMenuEntry] $self configurelist $args } method C-menu {option value} { if {$value ne "" && ![winfo exists $value]} { return -code error "invalid widget \"$value\"" } set options($option) $value } method C-image {option value} { set options($option) $value if {$value eq "default"} { } } } # Bindings for menu portion. # # This is a variant of the ttk menubutton.tcl bindings. # See menubutton.tcl for detailed behavior info. # namespace eval ttk { bind TMenuEntry { %W state active } bind TMenuEntry { %W state !active } bind TMenuEntry <> { ttk::menuentry::Popdown %W %x %y } bind TMenuEntry { ttk::menuentry::Popdown %W 10 10 } if {[tk windowingsystem] eq "x11"} { bind TMenuEntry { ttk::menuentry::Pulldown %W %x %y } bind TMenuEntry { ttk::menuentry::TransferGrab %W } bind TMenuEntry { ttk::menuentry::TransferGrab %W } } else { bind TMenuEntry \ { %W state pressed ; ttk::menuentry::Popdown %W %x %y } bind TMenuEntry { %W state !pressed } } namespace eval menuentry { variable State array set State { pulldown 0 oldcursor {} } } } # PostPosition -- # Returns the x and y coordinates where the menu # should be posted, based on the menuentry and menu size # and -direction option. # # TODO: adjust menu width to be at least as wide as the button # for -direction above, below. # proc ttk::menuentry::PostPosition {mb menu} { set x [winfo rootx $mb] set y [winfo rooty $mb] set dir "below" ; #[$mb cget -direction] set bw [winfo width $mb] set bh [winfo height $mb] set mw [winfo reqwidth $menu] set mh [winfo reqheight $menu] set sw [expr {[winfo screenwidth $menu] - $bw - $mw}] set sh [expr {[winfo screenheight $menu] - $bh - $mh}] switch -- $dir { above { if {$y >= $mh} { incr y -$mh } { incr y $bh } } below { if {$y <= $sh} { incr y $bh } { incr y -$mh } } left { if {$x >= $mw} { incr x -$mw } { incr x $bw } } right { if {$x <= $sw} { incr x $bw } { incr x -$mw } } flush { # post menu atop menuentry. # If there's a menu entry whose label matches the # menuentry -text, assume this is an optionmenu # and place that entry over the menuentry. set index [FindMenuEntry $menu [$mb cget -text]] if {$index ne ""} { incr y -[$menu yposition $index] } } } return [list $x $y] } # Popdown -- # Post the menu and set a grab on the menu. # proc ttk::menuentry::Popdown {me x y} { if {[$me instate disabled] || [set menu [$me cget -menu]] eq "" || [$me identify $x $y] ne "MenuEntry.icon"} { return } foreach {x y} [PostPosition $me $menu] { break } tk_popup $menu $x $y } # Pulldown (X11 only) -- # Called when Button1 is pressed on a menuentry. # Posts the menu; a subsequent ButtonRelease # or Leave event will set a grab on the menu. # proc ttk::menuentry::Pulldown {mb x y} { variable State if {[$mb instate disabled] || [set menu [$mb cget -menu]] eq "" || [$mb identify $x $y] ne "MenuEntry.icon"} { return } foreach {x y} [PostPosition $mb $menu] { break } set State(pulldown) 1 set State(oldcursor) [$mb cget -cursor] $mb state pressed $mb configure -cursor [$menu cget -cursor] $menu post $x $y tk_menuSetFocus $menu } # TransferGrab (X11 only) -- # Switch from pulldown mode (menuentry has an implicit grab) # to popdown mode (menu has an explicit grab). # proc ttk::menuentry::TransferGrab {mb} { variable State if {$State(pulldown)} { $mb configure -cursor $State(oldcursor) $mb state {!pressed !active} set State(pulldown) 0 grab -global [$mb cget -menu] } } # FindMenuEntry -- # Hack to support tk_optionMenus. # Returns the index of the menu entry with a matching -label, # -1 if not found. # proc ttk::menuentry::FindMenuEntry {menu s} { set last [$menu index last] if {$last eq "none"} { return "" } for {set i 0} {$i <= $last} {incr i} { if {![catch {$menu entrycget $i -label} label] && ($label eq $s)} { return $i } } return "" } package provide widget::menuentry 1.0.1 tcltk2/inst/tklibs/widget3.2/arrowb.tcl0000644000176200001440000000742615017041713017440 0ustar liggesusers##+########################################################################## # # Reference # http://wiki.tcl.tk/8554 # # arrows.tcl -- bitmaps for eight directional arrows # by Keith Vetter, Mar 12, 2003 # by Keith Vetter, July 2, 2010 added diagonal arrows # snit class by Andreas Kupries # package require widget snit::widgetadaptor widget::arrowbutton { delegate option * to hull except -image delegate method * to hull option -orientation \ -configuremethod C-orientation \ -validatemethod V-orientation constructor {args} { installhull using ttk::button $self configurelist $args return } method C-orientation {o value} { set options($o) $value $hull configure -image ::widget::arrowbutton::bit::$value return } method V-orientation {o value} { if {$value in $ourorientation} return return -code error "Expected one of [linsert [join $ourorientation {, }] end-1 or], got \"$value\"" } typevariable ourorientation { down downleft downright left right star up upleft upright } } image create bitmap ::widget::arrowbutton::bit::up -data { #define up_width 11 #define up_height 11 static char up_bits = { 0x00, 0x00, 0x20, 0x00, 0x70, 0x00, 0xf8, 0x00, 0xfc, 0x01, 0xfe, 0x03, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00, 0x00, 0x00, 0x00, 0x00 } } image create bitmap ::widget::arrowbutton::bit::down -data { #define down_width 11 #define down_height 11 static char down_bits = { 0x00, 0x00, 0x00, 0x00, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00, 0xfe, 0x03, 0xfc, 0x01, 0xf8, 0x00, 0x70, 0x00, 0x20, 0x00, 0x00, 0x00 } } image create bitmap ::widget::arrowbutton::bit::left -data { #define left_width 11 #define left_height 11 static char left_bits = { 0x00, 0x00, 0x20, 0x00, 0x30, 0x00, 0x38, 0x00, 0xfc, 0x01, 0xfe, 0x01, 0xfc, 0x01, 0x38, 0x00, 0x30, 0x00, 0x20, 0x00, 0x00, 0x00 } } image create bitmap ::widget::arrowbutton::bit::right -data { #define right_width 11 #define right_height 11 static char right_bits = { 0x00, 0x00, 0x20, 0x00, 0x60, 0x00, 0xe0, 0x00, 0xfc, 0x01, 0xfc, 0x03, 0xfc, 0x01, 0xe0, 0x00, 0x60, 0x00, 0x20, 0x00, 0x00, 0x00 } } image create bitmap ::widget::arrowbutton::bit::upleft -data { #define upleft_width 11 #define upleft_height 11 static char upleft_bits = { 0x00, 0x00, 0x7e, 0x00, 0x3e, 0x00, 0x3e, 0x00, 0x7e, 0x00, 0xfe, 0x00, 0xf2, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00 } } image create bitmap ::widget::arrowbutton::bit::upright -data { #define upright_width 11 #define upright_height 11 static char upright_bits = { 0x00, 0x00, 0xf0, 0x03, 0xe0, 0x03, 0xe0, 0x03, 0xf0, 0x03, 0xf8, 0x03, 0x7c, 0x02, 0x38, 0x00, 0x10, 0x00, 0x00, 0x00, 0x00, 0x00 } } image create bitmap ::widget::arrowbutton::bit::downleft -data { #define downleft_width 11 #define downleft_height 11 static char downleft_bits = { 0x00, 0x00, 0x00, 0x00, 0x40, 0x00, 0xe0, 0x00, 0xf2, 0x01, 0xfe, 0x00, 0x7e, 0x00, 0x3e, 0x00, 0x3e, 0x00, 0x7e, 0x00, 0x00, 0x00 } } image create bitmap ::widget::arrowbutton::bit::downright -data { #define downright_width 11 #define downright_height 11 static char downright_bits = { 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x38, 0x00, 0x7c, 0x02, 0xf8, 0x03, 0xf0, 0x03, 0xe0, 0x03, 0xe0, 0x03, 0xf0, 0x03, 0x00, 0x00 } } image create bitmap ::widget::arrowbutton::bit::star -data { #define plus_width 11 #define plus_height 11 static char plus_bits = { 0x00, 0x00, 0x22, 0x02, 0x24, 0x01, 0xa8, 0x00, 0x70, 0x00, 0xfe, 0x03, 0x70, 0x00, 0xa8, 0x00, 0x24, 0x01, 0x22, 0x02, 0x00, 0x00 } } package provide widget::arrowbutton 1 return tcltk2/inst/tklibs/widget3.2/toolbar.tcl0000644000176200001440000001735315017041713017606 0ustar liggesusers# -*- tcl -*- # # toolbar - /snit::widget # Manage items in a toolbar. # # RCS: @(#) $Id: toolbar.tcl,v 1.12 2010/06/01 18:06:52 hobbs Exp $ # # ## Padding can be a list of {padx pady} # -ipad -default 1 ; provides padding around each status bar item # -pad -default 0 ; provides general padding around the status bar # -separator -default {} ; one of {top left bottom right {}} # # All other options to frame # # Methods # $path getframe => $frame # $path add $widget ?args? => $widget # All other methods to frame # # Bindings # NONE # if 0 { # Example lappend auto_path ~/cvs/tcllib/tklib/modules/widget package require widget::toolbar set f [ttk::frame .f -padding 4] pack $f -fill both -expand 1 set tb [widget::toolbar .f.tb] pack $tb -fill both -expand 1 $tb add button foo -text Foo $tb add button bar -text Bar -separator 1 $tb add button baz -text Baz set b [ttk::button $tb.zippy -text Zippy -state disabled] $tb add $b } package require widget #package require tooltip snit::widget widget::toolbar { hulltype ttk::frame component separator component frame delegate option * to hull delegate method * to hull option -wrap -default 0 -type [list snit::boolean] option -separator -default {} -configuremethod C-separator \ -type [list snit::enum -values [list top left bottom right {}]] # -pad provides general padding around the status bar # -ipad provides padding around each status bar item # Padding can be a list of {padx pady} option -ipad -default 2 -configuremethod C-ipad \ -type [list snit::listtype -type {snit::integer} -minlen 1 -maxlen 4] delegate option -pad to frame as -padding variable ITEMS -array {} variable uid 0 constructor {args} { $hull configure -height 18 install frame using ttk::frame $win.frame install separator using ttk::separator $win.separator grid $frame -row 1 -column 1 -sticky news grid columnconfigure $win 1 -weight 1 # we should have a binding to wrap long toolbars #bind $win [mymethod resize [list $win] %w] $self configurelist $args } method C-ipad {option value} { set options($option) $value # returns pad values - each will be a list of 2 ints foreach {px py} [$self _padval $value] { break } foreach w [grid slaves $frame] { if {[string match _sep* $w]} { grid configure $w -padx $px -pady 0 } else { grid configure $w -padx $px -pady $py } } } method C-separator {option value} { set options($option) $value switch -exact -- $value { top { $separator configure -orient horizontal grid $separator -row 0 -column 1 -sticky ew } left { $separator configure -orient vertical grid $separator -row 1 -column 0 -sticky ns } bottom { $separator configure -orient horizontal grid $separator -row 2 -column 1 -sticky ew } right { $separator configure -orient vertical grid $separator -row 1 -column 2 -sticky ns } {} { grid remove $separator } } } # Use this or 'add' - but not both method getframe {} { return $frame } method add {what args} { if {[winfo exists $what]} { set w $what set symbol $w set ours 0 } else { set w $frame._$what[incr uid] set symbol [lindex $args 0] set args [lrange $args 1 end] if {![llength $args] || $symbol eq "%AUTO%"} { # Autogenerate symbol name set symbol _$what$uid } if {[info exists ITEMS($symbol)]} { return -code error "item '$symbol' already exists" } if {$what eq "label" || $what eq "button" || $what eq "checkbutton" || $what eq "radiobutton"} { set w [ttk::$what $w -style Toolbutton -takefocus 0] } elseif {$what eq "separator"} { set w [ttk::separator $w -orient vertical] } elseif {$what eq "space"} { set w [ttk::frame $w] } else { return -code error "unknown item type '$what'" } set ours 1 } set opts(-weight) [string equal $what "space"] set opts(-separator) 0 set opts(-sticky) news set opts(-pad) $options(-ipad) if {$what eq "separator"} { # separators should not have pady by default lappend opts(-pad) 0 } set cmdargs [list] set len [llength $args] for {set i 0} {$i < $len} {incr i} { set key [lindex $args $i] set val [lindex $args [incr i]] if {$key eq "--"} { eval [list lappend cmdargs] [lrange $args $i end] break } if {[info exists opts($key)]} { set opts($key) $val } else { # no error - pass to command lappend cmdargs $key $val } } if {[catch {eval [linsert $cmdargs 0 $w configure]} err]} { # we only want to destroy widgets we created if {$ours} { destroy $w } return -code error $err } set ITEMS($symbol) $w widget::isa listofint 4 -pad $opts(-pad) # returns pad values - each will be a list of 2 ints foreach {px py} [$self _padval $opts(-pad)] { break } # get cols,rows extent foreach {cols rows} [grid size $frame] break # Add separator if requested, and we aren't the first element if {$opts(-separator) && $cols != 0} { set sep [ttk::separator $frame._sep[winfo name $w] \ -orient vertical] # No pady for separators, and adjust padx for separator space set sx [lindex $px 0] if {$sx < 2} { set sx 2 } lset px 0 0 grid $sep -row 0 -column $cols -sticky ns -padx $sx -pady 0 incr cols } grid $w -in $frame -row 0 -column $cols -sticky $opts(-sticky) \ -pady $py -padx $px grid columnconfigure $frame $cols -weight $opts(-weight) return $symbol } method remove {args} { set destroy [string equal [lindex $args 0] "-destroy"] if {$destroy} { set args [lrange $args 1 end] } foreach sym $args { # Should we ignore unknown (possibly already removed) items? #if {![info exists ITEMS($sym)]} { continue } set w $ITEMS($sym) # separator name is based off item name set sep $frame._sep[winfo name $w] # destroy separator for remove or destroy case destroy $sep if {$destroy} { destroy $w } else { grid forget $w } unset ITEMS($sym) # XXX separator of next item is no longer necessary, if it exists } } method delete {args} { eval [linsert $args 0 $self remove -destroy] } method itemconfigure {symbol args} { if {[info exists ITEMS($symbol)]} { # configure exact item return [eval [linsert $args 0 $ITEMS($symbol) configure]] } # configure based on $symbol as a glob pattern set res {} foreach sym [array names ITEMS -glob $symbol] { lappend res \ [catch { eval [linsert $args 0 $ITEMS($sym) configure] } msg] \ $msg } # return something when we can figure out what is good to return #return $res } method itemcget {symbol option} { if {![info exists ITEMS($symbol)]} { return -code error "unknown toolbar item '$symbol'" } return [$ITEMS($symbol) cget $option] } method itemid {symbol} { if {![info exists ITEMS($symbol)]} { return -code error "unknown toolbar item '$symbol'" } return $ITEMS($symbol) } method items {{ptn *}} { if {$ptn ne "*"} { return [array names ITEMS $ptn] } return [array names ITEMS] } method _padval {val} { set len [llength $val] if {$len == 0} { return [list 0 0 0 0] } elseif {$len == 1} { return [list [list $val $val] [list $val $val]] } elseif {$len == 2} { set x [lindex $val 0] ; set y [lindex $val 1] return [list [list $x $x] [list $y $y]] } elseif {$len == 3} { return [list [list [lindex $val 0] [lindex $val 2]] \ [list [lindex $val 1] [lindex $val 1]]] } else { return $val } } method resize {w width} { if {$w ne $win} { return } if {$width < [winfo reqwidth $win]} { # Take the last column item and move it down } } } package provide widget::toolbar 1.2.1 tcltk2/inst/tklibs/widget3.2/superframe.tcl0000644000176200001440000000752715017041713020317 0ustar liggesusers# -*- tcl -*- # # superframe.tcl - # # Superframe widget - enhanced labelframe widget # # RCS: @(#) $Id: superframe.tcl,v 1.4 2010/06/01 18:06:52 hobbs Exp $ # # Allows 3 styles of labelframes: # border standard labelframe # whitespace labelframe with inset contents, no border # separator labelframe with inset contents, topright separator # # Based on OS X grouping types: # http://developer.apple.com/documentation/UserExperience/Conceptual/OSXHIGuidelines/XHIGLayout/chapter_19_section_4.html # # ### ######### ########################### ## Prerequisites package require widget # ### ######### ########################### ## Implementation snit::widgetadaptor widget::superframe { # ### ######### ########################### delegate option * to hull except {-style -labelwidget -text -font} delegate method * to hull option -style -default border -readonly 1; option -labelwidget -default "" -configuremethod C-labelwidget; option -text -default "" -configuremethod C-text; option -font -default "" -configuremethod C-font; # ### ######### ########################### ## Public API. Construction constructor {args} { set wtype ttk::labelframe # Grab -style option for processing - do not pass through set idx [lsearch -exact $args "-style"] if {$idx != -1} { set options(-style) [lindex $args [expr {$idx + 1}]] set args [lreplace $args $idx [expr {$idx + 1}]] } set styles [list border whitespace separator] if {[lsearch -exact $styles $options(-style)] == -1} { return -code error \ "style must be one of: border, whitespace or separator" } parray options if {$options(-style) ne "border"} { set wtype labelframe } installhull using $wtype if {$options(-style) ne "border"} { set args [linsert $args 0 -relief flat -borderwidth 0] } if {$options(-style) eq "separator"} { set sf [ttk::frame $win._labelwidget] ttk::label $sf.lbl -text $options(-text) ttk::separator $sf.sep -orient horizontal grid $sf.lbl -row 0 -column 0 -stick sew grid $sf.sep -row 0 -column 1 -stick sew -pady 2 -padx 2 grid columnconfigure $sf 1 -weight 1 grid rowconfigure $sf 0 -weight 1 $hull configure -labelwidget $sf bind $win \ [subst { if {"%W" eq "$win"} { $self SepSize } }] } $self configurelist $args return } # ### ######### ########################### ## Public API. Retrieve components method labelwidget {} { if {$options(-style) ne "separator"} { return [$hull cget -labelwidget] } else { return $win._labelwidget } } method SepSize {} { if {$options(-style) ne "separator"} { return 0 } set lw $win._labelwidget set rw [winfo width $win] set lrw [winfo width $lw.lbl] set width [expr {$rw - $lrw - 10}] grid columnconfigure $lw 1 -minsize $width } # ### ######### ########################### ## Internal. Handling option changes. method C-labelwidget {option value} { if {$options(-style) ne "separator"} { $hull configure -labelwidget $value } else { set oldw [$hull cget -labelwidget] if {$oldw ne ""} { grid forget $oldw } if {$oldw eq $value || $value eq ""} { return } grid $value -in $win._labelwidget -row 0 -column 0 -sticky ew } set options($option) $value } method C-text {option value} { if {$options(-style) ne "separator"} { $hull configure -text $value } else { $win._labelwidget.lbl configure -text $value } set options($option) $value } method C-font {option value} { if {$options(-style) ne "separator"} { $hull configure -font $value } else { $win._labelwidget.lbl configure -font $value } set options($option) $value } # ### ######### ########################### } # ### ######### ########################### ## Ready for use package provide widget::superframe 1.0.1 tcltk2/inst/tklibs/widget3.2/scrollw.tcl0000644000176200001440000001661315017041713017627 0ustar liggesusers# -*- tcl -*- # # scrollw.tcl - # # Scrolled widget # # RCS: @(#) $Id: scrollw.tcl,v 1.15 2010/06/01 18:06:52 hobbs Exp $ # # Creation and Options - widget::scrolledwindow $path ... # -scrollbar -default "both" ; vertical horizontal none # -auto -default "both" ; vertical horizontal none # -sides -default "se" ; # -size -default 0 ; scrollbar -width (not recommended to change) # -ipad -default {0 0} ; represents internal {x y} padding between # ; scrollbar and given widget # All other options to frame # # Methods # $path getframe => $frame # $path setwidget $widget => $widget # All other methods to frame # # Bindings # NONE # if 0 { # Samples package require widget::scrolledwindow #set sw [widget::scrolledwindow .sw -scrollbar vertical] #set text [text .sw.text -wrap word] #$sw setwidget $text #pack $sw -fill both -expand 1 set sw [widget::scrolledwindow .sw -borderwidth 1 -relief sunken] set text [text $sw.text -borderwidth 0 -height 4 -width 20] $sw setwidget $text pack $sw -fill both -expand 1 -padx 4 -pady 4 set sw [widget::scrolledwindow .ssw -borderwidth 2 -relief solid] set text [text $sw.text -borderwidth 0 -height 4 -width 20] $sw setwidget $text pack $sw -fill both -expand 1 -padx 4 -pady 4 } ### package require widget snit::widget widget::scrolledwindow { hulltype ttk::frame component hscroll component vscroll delegate option * to hull delegate method * to hull #delegate option -size to {hscroll vscroll} as -width option -scrollbar -default "both" -configuremethod C-scrollbar \ -type [list snit::enum -values [list none horizontal vertical both]] option -auto -default "both" -configuremethod C-scrollbar \ -type [list snit::enum -values [list none horizontal vertical both]] option -sides -default "se" -configuremethod C-scrollbar \ -type [list snit::enum -values [list ne en nw wn se es sw ws]] option -size -default 0 -configuremethod C-size \ -type [list snit::integer -min 0 -max 30] option -ipad -default 0 -configuremethod C-ipad \ -type [list snit::listtype -type {snit::integer} -minlen 1 -maxlen 2] typevariable scrollopts {none horizontal vertical both} variable realized 0 ; # set when first Configure'd variable hsb -array { packed 0 present 0 auto 0 row 2 col 1 lastmin -1 lastmax -1 lock 0 sticky "ew" padx 0 pady 0 } variable vsb -array { packed 0 present 0 auto 0 row 1 col 2 lastmin -1 lastmax -1 lock 0 sticky "ns" padx 0 pady 0 } variable pending {} ; # pending after id for scrollbar mgmt constructor args { if {[tk windowingsystem] ne "aqua"} { # ttk scrollbars on aqua are a bit wonky still install hscroll using ttk::scrollbar $win.hscroll \ -orient horizontal -takefocus 0 install vscroll using ttk::scrollbar $win.vscroll \ -orient vertical -takefocus 0 } else { install hscroll using scrollbar $win.hscroll \ -orient horizontal -takefocus 0 install vscroll using scrollbar $win.vscroll \ -orient vertical -takefocus 0 # in case the scrollbar has been overridden ... catch {$hscroll configure -highlightthickness 0} catch {$vscroll configure -highlightthickness 0} } set hsb(bar) $hscroll set vsb(bar) $vscroll bind $win [mymethod _realize $win] grid columnconfigure $win 1 -weight 1 grid rowconfigure $win 1 -weight 1 set pending [after idle [mymethod _setdata]] $self configurelist $args } destructor { after cancel $pending set pending {} } # Do we need this ?? method getframe {} { return $win } variable setwidget {} method setwidget {widget} { if {$setwidget eq $widget} { return } if {[winfo exists $setwidget]} { grid remove $setwidget # in case we only scroll in one direction catch {$setwidget configure -xscrollcommand ""} catch {$setwidget configure -yscrollcommand ""} $hscroll configure -command {} $vscroll configure -command {} set setwidget {} } if {$pending ne {}} { # ensure we have called most recent _setdata after cancel $pending $self _setdata } if {[winfo exists $widget]} { set setwidget $widget grid $widget -in $win -row 1 -column 1 -sticky news # in case we only scroll in one direction if {$hsb(present)} { $widget configure -xscrollcommand [mymethod _set_scroll hsb] $hscroll configure -command [list $widget xview] } if {$vsb(present)} { $widget configure -yscrollcommand [mymethod _set_scroll vsb] $vscroll configure -command [list $widget yview] } } return $widget } method C-size {option value} { set options($option) $value $vscroll configure -width $value $hscroll configure -width $value } method C-scrollbar {option value} { set options($option) $value after cancel $pending set pending [after idle [mymethod _setdata]] } method C-ipad {option value} { set options($option) $value # double value to ensure a single int value covers pad x and y foreach {padx pady} [concat $value $value] { break } set vsb(padx) [list $padx 0] ; set vsb(pady) 0 set hsb(padx) 0 ; set vsb(pady) [list $pady 0] if {$vsb(present) && $vsb(packed)} { grid configure $vsb(bar) -padx $vsb(padx) -pady $vsb(pady) } if {$hsb(present) && $hsb(packed)} { grid configure $hsb(bar) -padx $hsb(padx) -pady $hsb(pady) } } method _set_scroll {varname vmin vmax} { if {!$realized} { return } # This is only called if the scrollbar is attached properly upvar 0 $varname sb if {$sb(auto)} { if {!$sb(lock)} { # One last check to avoid loops when not locked if {$vmin == $sb(lastmin) && $vmax == $sb(lastmax)} { return } set sb(lastmin) $vmin set sb(lastmax) $vmax } if {$sb(packed) && $vmin == 0 && $vmax == 1} { if {!$sb(lock)} { set sb(packed) 0 grid remove $sb(bar) } } elseif {!$sb(packed) && ($vmin != 0 || $vmax != 1)} { set sb(packed) 1 grid $sb(bar) -column $sb(col) -row $sb(row) \ -sticky $sb(sticky) -padx $sb(padx) -pady $sb(pady) } set sb(lock) 1 update idletasks set sb(lock) 0 } $sb(bar) set $vmin $vmax } method _setdata {} { set pending {} set bar [lsearch -exact $scrollopts $options(-scrollbar)] set auto [lsearch -exact $scrollopts $options(-auto)] set hsb(present) [expr {$bar & 1}] ; # idx 1 or 3 set hsb(auto) [expr {$auto & 1}] ; # idx 1 or 3 set hsb(row) [expr {[string match *n* $options(-sides)] ? 0 : 2}] set hsb(col) 1 set hsb(sticky) "ew" set vsb(present) [expr {$bar & 2}] ; # idx 2 set vsb(auto) [expr {$auto & 2}] ; # idx 2 set vsb(row) 1 set vsb(col) [expr {[string match *w* $options(-sides)] ? 0 : 2}] set vsb(sticky) "ns" if {$setwidget eq ""} { grid remove $hsb(bar) grid remove $vsb(bar) set hsb(packed) 0 set vsb(packed) 0 return } foreach varname {hsb vsb} { upvar 0 $varname sb foreach {vmin vmax} [$sb(bar) get] { break } set sb(packed) [expr {$sb(present) && (!$sb(auto) || ($vmin != 0 || $vmax != 1))}] if {$sb(packed)} { grid $sb(bar) -column $sb(col) -row $sb(row) \ -sticky $sb(sticky) -padx $sb(padx) -pady $sb(pady) } else { grid remove $sb(bar) } } } method _realize {w} { if {$w eq $win} { bind $win {} set realized 1 } } } package provide widget::scrolledwindow 1.2.1 tcltk2/inst/tklibs/widget3.2/widget_dateentry.man0000644000176200001440000000536415017041713021476 0ustar liggesusers[comment {-*- tcl -*- doctools manpage}] [vset VERSION 0.98] [manpage_begin widget_dateentry n [vset VERSION]] [keywords date] [keywords dateentry] [keywords megawidget] [keywords snit] [keywords widget] [moddesc {Various megawidgets}] [titledesc {Date Entry Megawidget}] [category Widget] [require Tcl 8.4] [require Tk 8.4] [require widget [opt 3.0]] [require widget::dateentry [opt [vset VERSION]]] [description] This package provides a dateentry megawidget (snidget). It is based on an ttk::entry. All widget commands of the ttk::entry are available for the dateentry. [para] [list_begin definitions] [call [cmd widget::dateentry] [arg pathname] [opt options]] [list_end] [section "WIDGET OPTIONS"] [para] [list_begin options] [opt_def -command] A command prefix to evaluate when a date was selected. The command prefix is executed in the global namespace and given two arguments, the raw date in seconds, and the formatted date, as per option [option -dateformat]. [opt_def -dateformat] The format of the date that is entered or returned. Default: %m/%d/%Y. [opt_def -firstday] See the [package widget::calendar] man page. [opt_def -font] Select the font used in the widget. It defaults to Helvetica 9. [opt_def -highlightcolor] See the [package widget::calendar] man page. See the calendar man page. [opt_def -language] See the [package widget::calendar] man page. [opt_def -shadecolor] See the [package widget::calendar] man page. [opt_def -showpast] See the [package widget::calendar] man page. [opt_def -textvariable] Specifies the name of a variable whose value is linked to the entry widget's contents. Whenever the variable changes value, the widget's contents are updated, and vice versa. [list_end] [section "WIDGET COMMAND"] [list_begin definitions] [call [arg pathname] [cmd get]] Returns the selected date. [call [arg pathname] [cmd set] [arg date]] Programmatically sets a new date. Expects that the date is in the same format as configured by option [option -dateformat]. [para] The same effect can also be achieved by setting a linked [option -textvariable]. [list_end] [section "DEFAULT BINDINGS"] On creation of the dateentry widget the following bindings are installed. For navigation within the calendar, see its manpage. [list_begin itemized] [item] Button-1 - Accept and select the date and close the calendar window. [item] Return, space - Accept the selected date and close the calendar window [item] Escape - Close calendar window [item] Control-space - Show calendar window [list_end] [section EXAMPLE] [example { package require widget::dateentry; # or widget::all set t [widget::dateentry .de] pack $t -fill x -expand 1 }] [vset CATEGORY widget::dateentry] [include ../../support/devel/doc/feedback.inc] [manpage_end] tcltk2/inst/tklibs/widget3.2/calendar.tcl0000644000176200001440000005075215017041713017715 0ustar liggesusers# -*- tcl -*- # # calendar.tcl - # # Calendar widget drawn on a canvas. # Adapted from Suchenwirth code on the wiki. # # Copyright (c) 2008 Rüdiger Härtel # # # Creation and Options - widget::calendar $path ... # -command -default {} # -dateformat -default "%m/%d/%Y" # -font -default {Helvetica 9} # -textvariable -default {} # -firstday -default "monday" # -highlightcolor -default "#FFCC00" # -shadecolor -default "#888888" # -language -default en Supported languages: de, en, es, fr, gr, # he, it, ja, sv, pt, zh, fi ,tr, nl, ru, # crk, crx-nak, crx-lhe # -enablecmdonkey -default 1 # # All other options to canvas # # Methods # $path get => selected date, part can be # day,month,year, all # default is all # All other methods to canvas # # Bindings # NONE # if 0 { # Samples package require widget::calendar #set db [widget::calendar .db] #pack $sw -fill both -expand 1 } ### package require widget snit::widgetadaptor widget::calendar { delegate option * to hull delegate method * to hull option -firstday -default monday -configuremethod C-refresh \ -type [list snit::enum -values [list sunday monday]] option -textvariable -default {} -configuremethod C-textvariable option -command -default {} option -dateformat -default "%m/%d/%Y" -configuremethod C-refresh option -font -default {Helvetica 9} -configuremethod C-font option -highlightcolor -default "#FFCC00" -configuremethod C-refresh option -shadecolor -default "#888888" -configuremethod C-refresh option -language -default en -configuremethod C-language option -showpast -default 1 -configuremethod C-refresh \ -type {snit::boolean} option -enablecmdonkey -default 1 variable fullrefresh 1 variable pending "" ; # pending after id for refresh variable data -array { day 01 month 01 year 2007 linespace 0 cellspace 0 selday {} selmonth {} selyear {} } constructor args { installhull using canvas -highlightthickness 0 -borderwidth 0 \ -background white bindtags $win [linsert [bindtags $win] 1 Calendar] set now [clock scan "today 00:00:00"] foreach {data(day) data(month) data(year)} \ [clock format $now -format "%e %m %Y"] { break } scan $data(month) %lld data(month) ; # avoid leading 0 issues set data(selday) $data(day) set data(selmonth) $data(month) set data(selyear) $data(year) # Binding for the 'day' tagged items $win bind day <1> [mymethod adjust] # move days bind $win [mymethod adjust -1 0 0] bind $win [mymethod adjust 1 0 0] # move weeks bind $win [mymethod adjust -7 0 0] bind $win [mymethod adjust 7 0 0] # move months bind $win [mymethod adjust 0 -1 0] bind $win [mymethod adjust 0 1 0] # move years bind $win [mymethod adjust 0 0 -1] bind $win [mymethod adjust 0 0 1] bind $win [mymethod adjust today] bind $win [mymethod adjust Return] bind $win [mymethod adjust Return] bind $win [mymethod adjust Return] $self configurelist $args $self reconfigure $self refresh } destructor { if { $options(-textvariable) ne "" } { trace remove variable $options(-textvariable) write [mymethod DoUpdate] } } # # C-font -- # # Configure the font of the widget # ## method C-font {option value} { set options($option) $value $self reconfigure set fullrefresh 1 $self refresh } # # C-refresh -- # # Place holder for all options that need a refresh after # takeing over the new option. # ## method C-refresh {option value} { set options($option) $value $self refresh } # # C-textvariable -- # # Configure the textvariable for the widget. Installs a # trace handler for the variable. # If an empty textvariable is given the trace handler is # uninstalled. # ## method C-textvariable {option value} { if {![string match ::* $value]} { set value ::$value } set options($option) $value if {$value ne "" } { trace remove variable $options(-textvariable) write [mymethod DoUpdate] if { ![info exists $options($option)] } { set now [clock seconds] set $options($option) [clock format $now -format $options(-dateformat)] } trace add variable ::$value write [mymethod DoUpdate] if { [info exists $value] } { $self DoUpdate } } } # # C-language -- # # Configure the language of the calendar. # ## method C-language {option value} { set langs [list \ de en es fr gr he it ja sv pl pt zh fi tr nl ru \ crk \ crx-nak \ crx-lhe \ ] if { $value ni $langs } { return -code error "Unsupported language. Choose one of: $langs" } set options($option) $value $self refresh } # # DoUpdate -- # # Update the internal values of day, month and year when the # textvariable is written to (trace callback). # ## method DoUpdate { args } { set value $options(-textvariable) set tmp [set $value] if {$tmp eq ""} { return } if {$::tcl_version < 8.5} { # Prior to 8.4, users must use [clock]-recognized dateformat set date [clock scan $tmp] } else { set date [clock scan $tmp -format $options(-dateformat)] } foreach {data(day) data(month) data(year)} \ [clock format $date -format "%e %m %Y"] { break } scan $data(month) %lld data(month) ; # avoid leading 0 issues set data(selday) $data(day) set data(selmonth) $data(month) set data(selyear) $data(year) $self refresh } # # get -- # Return parts of the selected date or the complete date. # # Arguments: # what - Selects the part of the date or the complete date. # values , default is all # ## method get {{what all}} { switch -exact -- $what { "day" { return $data(selday) } "month" { return $data(selmonth) } "year" { return $data(selyear) } "all" { if {$data(selday) ne ""} { set date [clock scan $data(selmonth)/$data(selday)/$data(selyear)] set fmtdate [clock format $date -format $options(-dateformat)] return $fmtdate } } default { return -code error "unknown component to retrieve \"$what\",\ must be one of day, month or year" } } } # # adjust -- # # Adjust internal values of the calendar and update the contents # of the widget. This function is invoked by pressing the arrows # in the widget, on key bindings and by selecting a date with the # left mouse button. # # Arguments: # a) when used with keyboard navigation # dday - Difference in days # dmonth - Difference in months # dyear - Difference in years # b) when used with mouse button # "" - empty # ## method adjust { args } { set CallCmd 1 switch [llength $args] { 0 { # mouse button select catch {focus -force $win} msg set item [$hull find withtag current] set data(day) [$hull itemcget $item -text] } 1 { switch [lindex $args 0] { "today" { set Now [clock seconds] set data(day) [clock format $Now -format %d] set data(month) [clock format $Now -format %m] set data(year) [clock format $Now -format %Y] } "Return" { } } } 3 { # keyboard navigation # favor foreach approach over lassign to be # compatible with Tcl 8.4 foreach {dday dmonth dyear} $args {break} incr data(year) $dyear incr data(month) $dmonth set CallCmd $options(-enablecmdonkey) set maxday [$self numberofdays $data(month) $data(year)] if { ($data(day) + $dday) < 1} { incr data(month) -1 set maxday [$self numberofdays $data(month) $data(year)] set data(day) [expr {($data(day) + $dday) % $maxday}] } else { if { ($data(day) + $dday) > $maxday } { incr data(month) 1 set data(day) [expr {($data(day) + $dday) % $maxday}] } else { incr data(day) $dday } } if { $data(month) > 12} { set data(month) 1 incr data(year) } if { $data(month) < 1} { set data(month) 12 incr data(year) -1 } set maxday [$self numberofdays $data(month) $data(year)] if { $maxday < $data(day) } { set data(day) $maxday } } } set data(selday) $data(day) set data(selmonth) $data(month) set data(selyear) $data(year) set date [clock scan $data(month)/$data(day)/$data(year)] set fmtdate [clock format $date -format $options(-dateformat)] if { $CallCmd && $options(-textvariable) ne {}} { set $options(-textvariable) $fmtdate } if { $CallCmd && $options(-command) ne {}} { # pass single arg of formatted date chosen uplevel \#0 $options(-command) [list $fmtdate] } $self refresh } method cbutton {x y w command} { # Draw simple arrowbutton using Tk's line arrows set wd [expr {abs($w)}] set wd2 [expr {$wd/2. - ((abs($w) < 10) ? 1 : 2)}] set poly [$hull create line $x $y [expr {$x+$w}] $y -arrow last \ -arrowshape [list $wd $wd $wd2] \ -tags [list cbutton shadetext]] $hull bind $poly <1> $command } method reconfigure {} { set data(cellspace) [expr {[font measure $options(-font) "30"] * 2}] set w [expr {$data(cellspace) * 8}] set data(linespace) [font metrics $options(-font) -linespace] set h [expr {int($data(linespace) * 9.25)}] $hull configure -width $w -height $h } method refresh { } { # Idle deferred refresh after cancel $pending set pending [after idle [mymethod Refresh ]] } method Refresh { } { # Set up coords based on font spacing set x [expr {$data(cellspace) / 2}]; set x0 $x set dx $data(cellspace) set y [expr {int($data(linespace) * 1.75)}] set dy $data(linespace) set pad [expr {$data(linespace) / 2}] set xmax [expr {$x0+$dx*6}] set winw [$hull cget -width] set winh [$hull cget -height] if {$fullrefresh} { set fullrefresh 0 $hull delete all # Left and Right buttons set xs [expr {$data(cellspace) / 2}] $self cbutton [expr {$xs+2}] $pad -$xs [mymethod adjust 0 0 -1]; # << $self cbutton [expr {$xs*2}] $pad [expr {-$xs/1.5}] [mymethod adjust 0 -1 0]; # < set lxs [expr {$winw - $xs - 2}] $self cbutton $lxs $pad $xs [mymethod adjust 0 0 1]; # >> incr lxs -$xs $self cbutton $lxs $pad [expr {$xs/1.5}] [mymethod adjust 0 1 0]; # > # day (row) and weeknum (col) headers $hull create rect 0 [expr {$y - $pad}] $winw [expr {$y + $pad}] \ -tags shade $hull create rect 0 [expr {$y - $pad}] $dx $winh -tags shade } else { foreach tag {title otherday day highlight week} { $hull delete $tag } } # Title "Month Year" set title [$self formatMY $data(month) $data(year)] $hull create text [expr {$winw/2}] $pad -text $title -tag title \ -font $options(-font) -fill blue # weekdays - could be drawn on fullrefresh, watch -firstday change set weekdays $LANGS(weekdays,$options(-language)) if {$options(-firstday) eq "monday"} { $self lcycle weekdays } foreach i $weekdays { incr x $dx $hull create text $x $y -text $i -fill white \ -font $options(-font) -tag title } # place out the days set first $data(month)/1/$data(year) set weekday [clock format [clock scan $first] -format %w] if {$options(-firstday) eq "monday"} { set weekday [expr {($weekday+6)%7}] } # Print days preceding the 1st of the month set x [expr {$x0+$weekday*$dx}] set x1 $x; set offset 0 incr y $dy while {$weekday} { set t [clock scan "$first [incr offset] days ago"] set day [clock format $t -format "%e"] ; # %d w/o leading 0 $hull create text $x1 $y -text $day \ -font $options(-font) -tags [list otherday shadetext] incr weekday -1 incr x1 -$dx } set dmax [$self numberofdays $data(month) $data(year)] for {set d 1} {$d <= $dmax} {incr d} { incr x $dx if {($options(-showpast) == 0) && ($d < $data(selday)) && ($data(month) <= $data(selmonth)) && ($data(year) <= $data(selyear))} { # XXX day in the past - above condition currently broken set id [$hull create text $x $y -text $d \ -tags [list otherday shadetext] \ -font $options(-font)] } else { # current month day set id [$hull create text $x $y -text $d -tag day \ -font $options(-font)] } if {$d == $data(selday) && ($data(month) == $data(selmonth))} { # selected day $hull create rect [$hull bbox $id] -tags [list day highlight] } $hull raise $id if {$x > $xmax} { # Week of the year set x $x0 set week [$self getweek $d $data(month) $data(year)] $hull create text [expr {$x0}] $y -text $week -tag week \ -font $options(-font) -fill white incr y $dy } } # Week of year (last day) if {$x != $x0} { set week [$self getweek $dmax $data(month) $data(year)] $hull create text [expr {$x0}] $y -text $week -tag week \ -font $options(-font) -fill white for {set d 1} {$x <= $xmax} {incr d} { incr x $dx $hull create text $x $y -text $d \ -tags [list otherday shadetext] \ -font $options(-font) } } # Display Today line set now [clock seconds] set today "$LANGS(today,$options(-language)) [clock format $now -format $options(-dateformat)]" $hull create text [expr {$winw/2}] [expr {$winh - $pad}] -text $today \ -tag week -font $options(-font) -fill black # Make sure options-based items are set $hull itemconfigure highlight \ -fill $options(-highlightcolor) \ -outline $options(-highlightcolor) $hull itemconfigure shadetext -fill $options(-shadecolor) $hull itemconfigure shade -fill $options(-shadecolor) \ -outline $options(-shadecolor) } method getweek {day month year} { set _date [clock scan $month/$day/$year] return [clock format $_date -format %V] } method formatMY {month year} { set lang $options(-language) if {[info exists LANGS(mn,$lang)]} { set month [lindex $LANGS(mn,$lang) $month] } else { set _date [clock scan $month/1/$year] set month [clock format $_date -format %B] ; # full month name } if {[info exists LANGS(format,$lang)]} { set format $LANGS(format,$lang) } else { set format "%m %Y" ;# default } # Replace month/year and do any necessary substs return [subst [string map [list %m $month %Y $year] $format]] } method numberofdays {month year} { if {$month == 12} {set month 0; incr year} clock format [clock scan "[incr month]/1/$year 1 day ago"] -format %d } method lcycle _list { upvar $_list list set list [concat [lrange $list 1 end] [list [lindex $list 0]]] } typevariable LANGS -array { mn,crk { . Kis\u01E3p\u012Bsim Mikisiwip\u012Bsim Niskip\u012Bsim Ay\u012Bkip\u012Bsim S\u0101kipak\u0101wip\u012Bsim P\u0101sk\u0101wihowip\u012Bsim Paskowip\u012Bsim Ohpahowip\u012Bsim N\u014Dcihitowip\u012Bsim Pin\u0101skowip\u012Bsim Ihkopiwip\u012Bsim Paw\u0101cakinas\u012Bsip\u012Bsim } weekdays,crk {P\u01E3 N\u01E3s Nis N\u01E3 Niy Nik Ay} today,crk {} mn,crx-nak { . {Sacho Ooza'} {Chuzsul Ooza'} {Chuzcho Ooza'} {Shin Ooza'} {Dugoos Ooza'} {Dang Ooza'}\ {Talo Ooza'} {Gesul Ooza'} {Bit Ooza'} {Lhoh Ooza'} {Banghan Nuts'ukih} {Sacho Din'ai} } weekdays,crx-nak {Ji Jh WN WT WD Ts Sa} today,crx-nak {} mn,crx-lhe { . {'Elhdzichonun} {Yussulnun} {Datsannadulhnun} {Dulats'eknun} {Dugoosnun} {Daingnun}\ {Gesnun} {Nadlehcho} {Nadlehyaz} {Lhewhnandelnun} {Benats'ukuihnun} {'Elhdziyaznun} } weekdays,crx-lhe {Ji Jh WN WT WD Ts Sa} today,crx-lhe {} mn,de { . Januar Februar März April Mai Juni Juli August September Oktober November Dezember } weekdays,de {So Mo Di Mi Do Fr Sa} today,de {Heute ist der} mn,en { . January February March April May June July August September October November December } weekdays,en {Su Mo Tu We Th Fr Sa} today,en {Today is} mn,es { . Enero Febrero Marzo Abril Mayo Junio Julio Agosto Septiembre Octubre Noviembre Diciembre } weekdays,es {Do Lu Ma Mi Ju Vi Sa} today,es {} mn,fr { . Janvier Février Mars Avril Mai Juin Juillet Août Septembre Octobre Novembre Décembre } weekdays,fr {Di Lu Ma Me Je Ve Sa} today,fr {} mn,gr { . Îýý???Ãýý?Ãýý??Ãýý ???Ãýý?Ãýý?Ãýý??Ãýý Îýý?ÃýýÃýý??Ãýý ÎýýÃýýÃýý????Ãýý Îýý?Îýý?Ãýý Îýý?Ãýý???Ãýý Îýý?Ãýý???Ãýý ÎýýÃýý??ÃýýÃýýÃýý?Ãýý ??ÃýýÃýýÎýý??Ãýý??Ãýý Îýý?ÃýýÃýý??Ãýý??Ãýý Îýý?Îýý??Ãýý??Ãýý Îýý??Îýý??Ãýý??Ãýý } weekdays,gr {ÎýýÃýýÃýý Îýý?Ãýý TÃýý? ??Ãýý ÃŽ ?? ÃŽ ?Ãýý ???} today,gr {} mn,he { . ×ýý× ×ýý×ýý? ?×ýý?×ýý×ýý? ×ýý?? ×ýý??×ýý×ýý ×ýý×ýý×ýý ×ýý×ýý× ×ýý ×ýý×ýý×ýý×ýý ×ýý×ýý×ýý×ýý?×ýý ??×ýý×ýý×ýý? ×ýý×ýý?×ýý×ýý×ýý? × ×ýý×ýý×ýý×ýý? ×ýý?×ýý×ýý? } weekdays,he {?×ýý?×ýý×ýý ?× ×ýý ?×ýý×ýý?×ýý ?×ýý×ýý?×ýý ×ýý×ýý×ýý?×ýý ?×ýý?×ýý ?×ýý?} today,he {} mn,it { . Gennaio Febraio Marte Aprile Maggio Giugno Luglio Agosto Settembre Ottobre Novembre Dicembre } weekdays,it {Do Lu Ma Me Gi Ve Sa} today,it {} format,ja {%Y\u5e74 %m\u6708} weekdays,ja {\u65e5 \u6708 \u706b \u6c34 \u6728 \u91d1 \u571f} today,ja {} mn,nl { . januari februari maart april mei juni juli augustus september oktober november december } weekdays,nl {Zo Ma Di Wo Do Vr Za} today,nl {} mn,ru { . \u042F\u043D\u0432\u0430\u0440\u044C \u0424\u0435\u0432\u0440\u0430\u043B\u044C \u041C\u0430\u0440\u0442 \u0410\u043F\u0440\u0435\u043B\u044C \u041C\u0430\u0439 \u0418\u044E\u043D\u044C \u0418\u044E\u043B\u044C \u0410\u0432\u0433\u0443\u0441\u0442 \u0421\u0435\u043D\u0442\u044F\u0431\u0440\u044C \u041E\u043A\u0442\u044F\u0431\u0440\u044C \u041D\u043E\u044F\u0431\u0440\u044C \u0414\u0435\u043A\u0430\u0431\u0440\u044C } weekdays,ru { \u432\u43e\u441 \u43f\u43e\u43d \u432\u442\u43e \u441\u440\u435 \u447\u435\u442 \u43f\u44f\u442 \u441\u443\u431 } today,ru {} mn,sv { . januari februari mars april maj juni juli augusti september oktober november december } weekdays,sv {s\u00F6n m\u00E5n tis ons tor fre l\u00F6r} today,sv {} mn,pt { . Janeiro Fevereiro Mar\u00E7o Abril Maio Junho Julho Agosto Setembro Outubro Novembro Dezembro } weekdays,pt {Dom Seg Ter Qua Qui Sex Sab} today,pt {} format,zh {%Y\u5e74 %m\u6708} mn,zh { . \u4e00 \u4e8c \u4e09 \u56db \u4e94 \u516d \u4e03 \u516b \u4e5d \u5341 \u5341\u4e00 \u5341\u4e8c } weekdays,zh {\u65e5 \u4e00 \u4e8c \u4e09 \u56db \u4e94 \u516d} today,zh {} mn,fi { . Tammikuu Helmikuu Maaliskuu Huhtikuu Toukokuu Kesäkuu Heinäkuu Elokuu Syyskuu Lokakuu Marraskuu Joulukuu } weekdays,fi {Ma Ti Ke To Pe La Su} today,fi {} mn,tr { . ocak \u015fubat mart nisan may\u0131s haziran temmuz a\u011fustos eyl\u00FCl ekim kas\u0131m aral\u0131k } weekdays,tr {pa'tesi sa \u00e7a pe cu cu'tesi pa} today,tr {} mn,pl { . stycze\u0144 luty marzec kwiecie\u0144 maj czerwiec lipiec sierpie\u0144 wrzesie\u0144 pa\u017adziernik listopad grudzie\u0144 } weekdays,pl {Ni Po Wt \u015ar Cz Pi So} today,pl {Dzisiaj jest} } } package provide widget::calendar 1.0.2 return tcltk2/inst/tklibs/widget3.2/widget_toolbar.man0000644000176200001440000000254615017041713021140 0ustar liggesusers[comment {-*- tcl -*- doctools manpage}] [manpage_begin widget_toolbar n 3.0] [keywords megawidget] [keywords snit] [keywords toolbar] [keywords widget] [moddesc {Various megawidgets}] [titledesc {Toolbar Megawidget}] [category Widget] [require Tcl 8.4] [require Tk 8.4] [require widget [opt 3.0]] [require widget::toolbar [opt 1.0]] [description] This package provides a toolbar megawidget (snidget). It makes use of the Tile/Ttk themed widget set. [para] [list_begin definitions] [call [cmd widget::toolbar] [arg pathname] [opt options]] [call getframe] [call add [opt item] [opt args]] [call delete item1 [opt item2] [opt ...]] [call itemcget symbol option] [call itemconfigure symbol [opt args]] [call items [opt pattern]] [call remove [opt -destroy] item1 [opt item2] [opt ...]] [list_end] [section "WIDGET OPTIONS"] [list_begin options] [opt_def -ipad] [opt_def -pad] [opt_def -separator] [list_end] [section "ITEM OPTIONS"] [list_begin options] [opt_def -pad] [opt_def -separator] [opt_def -sticky] [opt_def -weight] [list_end] [section EXAMPLE] [example { package require widget::toolbar ; # or widget::all set t [widget::toolbar .t] pack $t -fill x -expand 1 $t add button [button .b -text foo] $t add separator -pad {2 4} $t add button [button .c -text bar] }] [vset CATEGORY widget::toolbar] [include ../../support/devel/doc/feedback.inc] [manpage_end] tcltk2/inst/tklibs/widget3.2/widget.tcl0000644000176200001440000001037515017041713017424 0ustar liggesusers# -*- tcl -*- # # widget.tcl -- # # megawidget package that uses snit as the object system (snidgets) # # Copyright (c) 2005 Jeffrey Hobbs # package require Tk 8.4- package require snit # As most widgets need tile, do the right conditional require here if {![package vsatisfies [package provide Tk] 8.5-]} { package require tile } #package provide Widget 3.1 ; # at end namespace eval ::widget { if 0 { variable HaveMarlett \ [expr {[lsearch -exact [font families] "Marlett"] != -1}] snit::macro widget::HaveMarlett {} [list return $::widget::HaveMarlett] } } # widget::propagate -- (snit macro) # # Propagates an option to multiple components # # Arguments: # option option definition # args # Results: # Create method Propagate$option # snit::macro widget::propagate {option args} { # propagate option $optDefn ?-default ...? to $components ?as $realopt? set idx [lsearch -exact $args "to"] set cmd [linsert [lrange $args 0 [expr {$idx - 1}]] 0 option $option] foreach {components as what} [lrange $args [expr {$idx + 1}] end] { break } # ensure we have just the option name set option [lindex $option 0] set realopt [expr {$what eq "" ? $option : $what}] lappend cmd -configuremethod Propagate$option eval $cmd set body "\n" foreach comp $components { append body "\$[list $comp] configure [list $realopt] \$value\n" } append body "set [list options($option)] \$value\n" method Propagate$option {option value} $body } if {0} { # Currently not feasible due to snit's compiler-as-slave-interp snit::macro widget::tkoption {option args} { # XXX should support this # tkoption {-opt opt Opt} ?-default ""? from /wclass/ ?as $wopt? } snit::macro widget::tkresource {wclass wopt} { # XXX should support this # tkresource $wclass $wopt set w ".#widget#$wclass" if {![winfo exists $w]} { set w [$wclass $w] } set value [$w cget $wopt] after idle [list destroy $w] return $value } } # widget::tkresource -- # # Get the default option value from a widget class # # Arguments: # wclass widget class # wopt widget option # Results: # Returns default value of $wclass $wopt value # proc widget::tkresource {wclass wopt} { # XXX should support this # tkresource $wclass $wopt set w ".#widget#$wclass" if {![winfo exists $w]} { set w [$wclass $w] } set value [$w cget $wopt] after idle [list destroy $w] return $value } # ::widget::validate -- # # Used by widgets for option validate - *private* spec may change # # Arguments: # as type to compare as # range range/data info specific to $as # option option name # value value being validated # # Results: # Returns error or empty # proc ::widget::isa {as args} { foreach {range option value} $args { break } if {$as eq "list"} { if {[lsearch -exact $range $value] == -1} { return -code error "invalid $option option \"$value\",\ must be one of [join $range {, }]" } } elseif {$as eq "boolean" || $as eq "bool"} { foreach {option value} $args { break } if {![string is boolean -strict $value]} { return -code error "$option requires a boolean value" } } elseif {$as eq "integer" || $as eq "int"} { foreach {min max} $range { break } ##nagelfar ignore if {![string is integer -strict $value] || ($value < $min) || ($value > $max)} { return -code error "$option requires an integer in the\ range \[$min .. $max\]" } } elseif {$as eq "listofinteger" || $as eq "listofint"} { if {$range eq ""} { set range [expr {1<<16}] } set i 0 foreach val $value { ##nagelfar ignore if {![string is integer -strict $val] || ([incr i] > $range)} { return -code error "$option requires a list of integers" } } } elseif {$as eq "double"} { foreach {min max} $range { break } if {![string is double -strict $value] || ($value < $min) || ($value > $max)} { return -code error "$option requires a double in the\ range \[$min .. $max\]" } } elseif {$as eq "window"} { foreach {option value} $args { break } if {$value eq ""} { return } if {![winfo exists $value]} { return -code error "invalid window \"$value\"" } } else { return -code error "unknown validate type \"$as\"" } return } package provide widget 3.2 tcltk2/inst/tklibs/widget3.2/widget.man0000644000176200001440000000353115017041713017411 0ustar liggesusers[comment {-*- tcl -*- doctools manpage}] [vset VERSION 3.2] [manpage_begin widget n [vset VERSION]] [keywords bundle] [keywords calendar] [keywords dateentry] [keywords dialog] [keywords megawidget] [keywords menu] [keywords panelframe] [keywords ruler] [keywords screenruler] [keywords scrolledwindow] [keywords snit] [keywords statusbar] [keywords superframe] [keywords toolbar] [keywords widget] [moddesc {Various megawidgets}] [titledesc {Megawidget bundle}] [category Widget] [require Tcl 8.4] [require Tk 8.4] [require widget [opt [vset VERSION]]] [require snit] [description] This package provides megawidgets based on the snit oo system (snidgets). It makes use of the Tile/Ttk themed widget set. [para] [list_begin definitions] [call [cmd widget::validate] [arg as] [opt options]] commands: [list_end] [section WIDGETS] [list_begin definitions] [call [cmd widget::calendar] [arg pathname] [opt options]] options: [call [cmd widget::dateentry] [arg pathname] [opt options]] options: [call [cmd widget::dialog] [arg pathname] [opt options]] options: [call [cmd widget::menuentry] [arg pathname] [opt options]] options: [call [cmd widget::panelframe] [arg pathname] [opt options]] options: [call [cmd widget::ruler] [arg pathname] [opt options]] options: [call [cmd widget::screenruler] [arg pathname] [opt options]] options: [call [cmd widget::scrolledwindow] [arg pathname] [opt options]] options: [call [cmd widget::statusbar] [arg pathname] [opt options]] options: [call [cmd widget::superframe] [arg pathname] [opt options]] options: [call [cmd widget::toolbar] [arg pathname] [opt options]] options: [list_end] [section EXAMPLE] [example { package require widget::superframe ; # or widget::all pack [widget::superframe .f -type separator -text "SuperFrame:"] }] [vset CATEGORY widget] [include ../../support/devel/doc/feedback.inc] [manpage_end] tcltk2/inst/tklibs/widget3.2/ruler.tcl0000644000176200001440000004424615017041713017276 0ustar liggesusers# -*- tcl -*- # # ruler.tcl # # ruler widget and screenruler dialog # # Copyright (c) 2005 Jeffrey Hobbs. All Rights Reserved. # ### # Creation and Options - widget::ruler $path ... # -foreground -default black # -font -default {Helvetica 14} # -interval -default [list 5 25 100] # -sizes -default [list 4 8 12] # -showvalues -default 1 # -outline -default 1 # -grid -default 0 # -measure -default pixels ; {pixels points inches mm cm} # -zoom -default 1 # all other options inherited from canvas # # Methods # All methods passed to canvas # # Bindings # redraws # ### # Creation and Options - widget::screenruler $path ... # -alpha -default 0.8 # -title -default "" # -topmost -default 0 # -reflect -default 0 ; reflect desktop screen # -zoom -default 1 # # Methods # $path display # $path hide # All # # Bindings # if 0 { # Samples package require widget::screenruler set dlg [widget::screenruler .r -grid 1 -title "Screen Ruler"] $dlg menu add separator $dlg menu add command -label "Exit" -command { exit } $dlg display } package require widget 3 snit::widgetadaptor widget::ruler { delegate option * to hull delegate method * to hull option -foreground -default black -configuremethod C-redraw option -font -default {Helvetica 14} option -interval -default [list 5 25 100] -configuremethod C-redraw \ -type [list snit::listtype -type {snit::double} -minlen 3 -maxlen 3] option -sizes -default [list 4 8 12] -configuremethod C-redraw \ -type [list snit::listtype -type {snit::double} -minlen 3 -maxlen 3] option -showvalues -default 1 -configuremethod C-redraw \ -type [list snit::boolean] option -outline -default 1 -configuremethod C-redraw \ -type [list snit::boolean] option -grid -default 0 -configuremethod C-redraw \ -type [list snit::boolean] option -measure -default pixels -configuremethod C-measure \ -type [list snit::enum -values [list pixels points inches mm cm]] option -zoom -default 1 -configuremethod C-redraw \ -type [list snit::integer -min 1] variable shade -array {small gray medium gray large gray} constructor {args} { installhull using canvas -width 200 -height 50 \ -relief flat -bd 0 -background white -highlightthickness 0 $hull xview moveto 0 $hull yview moveto 0 $self _reshade bind $win [mymethod _resize %W %X %Y] #bind $win [mymethod _adjustinterval -1] #bind $win [mymethod _adjustinterval 1] #bind $win [mymethod _adjustinterval 1] $self configurelist $args $self redraw } destructor { catch {after cancel $redrawID} } ######################################## ## public methods ######################################## ## configure methods variable width 0 variable height 0 variable measure -array { what "" valid {pixels points inches mm cm} cm c mm m inches i points p pixels "" } variable redrawID {} method C-redraw {option value} { if {$value ne $options($option)} { set options($option) $value if {$option eq "-foreground"} { $self _reshade } $self redraw } } method C-measure {option value} { if {[set idx [lsearch -glob $measure(valid) $value*]] == -1} { return -code error "invalid $option value \"$value\":\ must be one of [join $measure(valid) {, }]" } set value [lindex $measure(valid) $idx] set measure(what) $measure($value) set options($option) $value $self redraw } ######################################## ## private methods method _reshade {} { set bg [$hull cget -bg] set fg $options(-foreground) set shade(small) [$self shade $bg $fg 0.15] set shade(medium) [$self shade $bg $fg 0.4] set shade(large) [$self shade $bg $fg 0.8] } method redraw {} { after cancel $redrawID set redrawID [after idle [mymethod _redraw]] } method _redraw {} { $hull delete ruler set width [winfo width $win] set height [winfo height $win] $self _redraw_x $self _redraw_y if {$options(-outline) || $options(-grid)} { if {[tk windowingsystem] eq "aqua"} { # Aqua has an odd off-by-one drawing set coords [list 0 0 $width $height] } else { set coords [list 0 0 [expr {$width-1}] [expr {$height-1}]] } $hull create rect $coords -width 1 -outline $options(-foreground) \ -tags [list ruler outline] } if {$options(-showvalues) && $height > 20} { if {$measure(what) ne ""} { set m [winfo fpixels $win 1$measure(what)] set txt "[format %.2f [expr {$width / $m}]] x\ [format %.2f [expr {$height / $m}]] $options(-measure)" } else { set txt "$width x $height" } if {$options(-zoom) > 1} { append txt " (x$options(-zoom))" } $hull create text 15 [expr {$height/2.}] \ -text $txt \ -anchor w -tags [list ruler value label] \ -fill $options(-foreground) } $hull raise large $hull raise value } method _redraw_x {} { foreach {sms meds lgs} $options(-sizes) { break } foreach {smi medi lgi} $options(-interval) { break } for {set x 0} {$x < $width} {set x [expr {$x + $smi}]} { set dx [winfo fpixels $win \ [expr {$x * $options(-zoom)}]$measure(what)] if {fmod($x, $lgi) == 0.0} { # draw large tick set h $lgs set tags [list ruler tick large] if {$x && $options(-showvalues) && $height > $lgs} { $hull create text [expr {$dx+1}] $h -anchor nw \ -text [format %g $x]$measure(what) \ -tags [list ruler value] } set fill $shade(large) } elseif {fmod($x, $medi) == 0.0} { set h $meds set tags [list ruler tick medium] set fill $shade(medium) } else { set h $sms set tags [list ruler tick small] set fill $shade(small) } if {$options(-grid)} { $hull create line $dx 0 $dx $height -width 1 -tags $tags \ -fill $fill } else { $hull create line $dx 0 $dx $h -width 1 -tags $tags \ -fill $options(-foreground) $hull create line $dx $height $dx [expr {$height - $h}] \ -width 1 -tags $tags -fill $options(-foreground) } } } method _redraw_y {} { foreach {sms meds lgs} $options(-sizes) { break } foreach {smi medi lgi} $options(-interval) { break } for {set y 0} {$y < $height} {set y [expr {$y + $smi}]} { set dy [winfo fpixels $win \ [expr {$y * $options(-zoom)}]$measure(what)] if {fmod($y, $lgi) == 0.0} { # draw large tick set w $lgs set tags [list ruler tick large] if {$y && $options(-showvalues) && $width > $lgs} { $hull create text $w [expr {$dy+1}] -anchor nw \ -text [format %g $y]$measure(what) \ -tags [list ruler value] } set fill $shade(large) } elseif {fmod($y, $medi) == 0.0} { set w $meds set tags [list ruler tick medium] set fill $shade(medium) } else { set w $sms set tags [list ruler tick small] set fill $shade(small) } if {$options(-grid)} { $hull create line 0 $dy $width $dy -width 1 -tags $tags \ -fill $fill } else { $hull create line 0 $dy $w $dy -width 1 -tags $tags \ -fill $options(-foreground) $hull create line $width $dy [expr {$width - $w}] $dy \ -width 1 -tags $tags -fill $options(-foreground) } } } method _resize {w X Y} { if {$w ne $win} { return } $self redraw } method _adjustinterval {dir} { set newint {} foreach i $options(-interval) { if {$dir < 0} { lappend newint [expr {$i/2.0}] } else { lappend newint [expr {$i*2.0}] } } set options(-interval) $newint $self redraw } method shade {orig dest frac} { if {$frac >= 1.0} {return $dest} elseif {$frac <= 0.0} {return $orig} foreach {oR oG oB} [winfo rgb $win $orig] \ {dR dG dB} [winfo rgb $win $dest] { set color [format "\#%02x%02x%02x" \ [expr {int($oR+double($dR-$oR)*$frac)}] \ [expr {int($oG+double($dG-$oG)*$frac)}] \ [expr {int($oB+double($dB-$oB)*$frac)}]] return $color } } } snit::widget widget::screenruler { hulltype toplevel component ruler -public ruler component menu -public menu delegate option * to ruler delegate method * to ruler option -alpha -default 0.8 -configuremethod C-alpha; option -title -default "" -configuremethod C-title; option -topmost -default 0 -configuremethod C-topmost; option -reflect -default 0 -configuremethod C-reflect; # override ruler zoom for reflection control as well option -zoom -default 1 -configuremethod C-zoom; option -showgeometry -default 0 -configuremethod C-showgeometry; variable alpha 0.8 ; # internal opacity value variable curinterval 5; variable curmeasure ""; variable grid 0; variable reflect -array {ok 0 image "" id ""} variable curdim -array {x 0 y 0 w 0 h 0} constructor {args} { wm withdraw $win wm overrideredirect $win 1 $hull configure -bg white install ruler using widget::ruler $win.ruler -width 200 -height 50 \ -relief flat -bd 0 -background white -highlightthickness 0 install menu using menu $win.menu -tearoff 0 # avoid 1.0 because we want to maintain layered class if {$::tcl_platform(platform) eq "windows" && $alpha >= 1.0} { set alpha 0.999 } catch {wm attributes $win -alpha $alpha} catch {wm attributes $win -topmost $options(-topmost)} grid $ruler -sticky news grid columnconfigure $win 0 -weight 1 grid rowconfigure $win 0 -weight 1 set reflect(ok) [expr {![catch {package require treectrl}] && [llength [info commands loupe]]}] if {$reflect(ok)} { set reflect(do) 0 set reflect(x) -1 set reflect(y) -1 set reflect(w) [winfo width $win] set reflect(h) [winfo height $win] set reflect(image) [image create photo [myvar reflect] \ -width $reflect(w) -height $reflect(h)] $ruler create image 0 0 -anchor nw -image $reflect(image) # Don't use options(-reflect) because it isn't 0/1 $menu add checkbutton -label "Reflect Desktop" \ -accelerator "r" -underline 0 \ -variable [myvar reflect(do)] \ -command "[list $win configure -reflect] \$[myvar reflect(do)]" bind $win [list $menu invoke "Reflect Desktop"] } $menu add checkbutton -label "Show Grid" \ -accelerator "d" -underline 8 \ -variable [myvar grid] \ -command "[list $ruler configure -grid] \$[myvar grid]" bind $win [list $menu invoke "Show Grid"] $menu add checkbutton -label "Show Geometry" \ -accelerator "g" -underline 5 \ -variable [myvar options(-showgeometry)] \ -command "[list $win configure -showgeometry] \$[myvar options(-showgeometry)]" bind $win [list $menu invoke "Show Geometry"] if {[tk windowingsystem] ne "x11"} { $menu add checkbutton -label "Keep on Top" \ -underline 8 -accelerator "t" \ -variable [myvar options(-topmost)] \ -command "[list $win configure -topmost] \$[myvar options(-topmost)]" bind $win [list $menu invoke "Keep on Top"] } set m [menu $menu.interval -tearoff 0] $menu add cascade -label "Interval" -menu $m -underline 0 foreach interval { {2 10 50} {4 20 100} {5 25 100} {10 50 100} } { $m add radiobutton -label [lindex $interval 0] \ -variable [myvar curinterval] -value [lindex $interval 0] \ -command [list $ruler configure -interval $interval] } set m [menu $menu.zoom -tearoff 0] $menu add cascade -label "Zoom" -menu $m -underline 0 foreach zoom {1 2 3 4 5 8 10} { set lbl ${zoom}x $m add radiobutton -label $lbl \ -underline 0 \ -variable [myvar options(-zoom)] -value $zoom \ -command "[list $win configure -zoom] \$[myvar options(-zoom)]" bind $win \ [list $m invoke [string map {% %%} $lbl]] } set m [menu $menu.measure -tearoff 0] $menu add cascade -label "Measurement" -menu $m -underline 0 foreach {val und} {pixels 0 points 1 inches 0 mm 0 cm 0} { $m add radiobutton -label $val \ -underline $und \ -variable [myvar curmeasure] -value $val \ -command [list $ruler configure -measure $val] } set m [menu $menu.opacity -tearoff 0] $menu add cascade -label "Opacity" -menu $m -underline 0 for {set i 10} {$i <= 100} {incr i 10} { set aval [expr {$i/100.}] $m add radiobutton -label "${i}%" \ -variable [myvar alpha] -value $aval \ -command [list $win configure -alpha $aval] } if {[tk windowingsystem] eq "aqua"} { bind $win [list tk_popup $menu %X %Y] # Aqua switches 2 and 3 ... bind $win [list tk_popup $menu %X %Y] } else { bind $win [list tk_popup $menu %X %Y] } bind $win [mymethod _resize %W %x %y %w %h] bind $win [mymethod _dragstart %W %X %Y] bind $win [mymethod _drag %W %X %Y] bind $win [mymethod _edgecheck %W %x %y] #$hull configure -menu $menu $self configurelist $args set grid [$ruler cget -grid] set curinterval [lindex [$ruler cget -interval] 0] set curmeasure [$ruler cget -measure] } destructor { catch { after cancel $reflect(id) image delete $reflect(image) } } ######################################## ## public methods method display {} { wm deiconify $win raise $win focus $win } method hide {} { wm withdraw $win } ######################################## ## configure methods method C-alpha {option value} { if {![string is double -strict $value] || $value < 0.0 || $value > 1.0} { return -code error "invalid $option value \"$value\":\ must be a double between 0 and 1" } set options($option) $value set alpha $value # avoid 1.0 because we want to maintain layered class if {$::tcl_platform(platform) eq "windows" && $alpha >= 1.0} { set alpha 0.999 } catch {wm attributes $win -alpha $alpha} } method C-title {option value} { wm title $win $value wm iconname $win $value set options($option) $value } method C-topmost {option value} { set options($option) $value catch {wm attributes $win -topmost $value} } method C-reflect {option value} { if {($value > 0) && !$reflect(ok)} { return -code error "no reflection possible" } after cancel $reflect(id) if {$value > 0} { if {$value < 50} { set value 50 } set reflect(id) [after idle [mymethod _reflect]] } else { catch {$reflect(image) blank} } set options($option) $value } method C-zoom {option value} { ##nagelfar ignore if {![string is integer -strict $value] || $value < 1} { return -code error "invalid $option value \"$value\":\ must be a valid integer >= 1" } $ruler configure -zoom $value set options($option) $value } method C-showgeometry {option value} { if {![string is boolean -strict $value]} { return -code error "invalid $option value \"$value\":\ must be a valid boolean" } set options($option) $value $ruler delete geoinfo if {$value} { set opts [list -borderwidth 1 -highlightthickness 1 -width 4] set x 20 set y 20 foreach d {x y w h} { set w $win._$d destroy $w eval [linsert $opts 0 entry $w -textvar [myvar curdim($d)]] $ruler create window $x $y -window $w -tags geoinfo bind $w [mymethod _placecmd] # Avoid toplevel bindings bindtags $w [list $w Entry all] incr x [winfo reqwidth $w] } } } ######################################## ## private methods method _placecmd {} { wm geometry $win $curdim(w)x$curdim(h)+$curdim(x)+$curdim(y) } method _resize {W x y w h} { if {$W ne $win} { return } set curdim(x) $x set curdim(y) $y set curdim(w) $w set curdim(h) $h } method _reflect {} { if {!$reflect(ok)} { return } set w [winfo width $win] set h [winfo height $win] set x [winfo pointerx $win] set y [winfo pointery $win] if {($reflect(w) != $w) || ($reflect(h) != $h)} { $reflect(image) configure -width $w -height $h set reflect(w) $w set reflect(h) $h } if {($reflect(x) != $x) || ($reflect(y) != $y)} { loupe $reflect(image) $x $y $w $h $options(-zoom) set reflect(x) $x set reflect(y) $y } if {$options(-reflect)} { set reflect(id) [after $options(-reflect) [mymethod _reflect]] } } variable edge -array { at 0 left 1 right 2 top 3 bottom 4 } method _edgecheck {w x y} { if {$w ne $ruler} { return } set edge(at) 0 set cursor "" if {$x < 4 || $x > ([winfo width $win] - 4)} { set cursor sb_h_double_arrow set edge(at) [expr {$x < 4 ? $edge(left) : $edge(right)}] } elseif {$y < 4 || $y > ([winfo height $win] - 4)} { set cursor sb_v_double_arrow set edge(at) [expr {$y < 4 ? $edge(top) : $edge(bottom)}] } $win configure -cursor $cursor } variable drag -array {} method _dragstart {w X Y} { set drag(X) [expr {$X - [winfo rootx $win]}] set drag(Y) [expr {$Y - [winfo rooty $win]}] set drag(w) [winfo width $win] set drag(h) [winfo height $win] $self _edgecheck $ruler $drag(X) $drag(Y) raise $win focus $ruler } method _drag {w X Y} { if {$edge(at) == 0} { set dx [expr {$X - $drag(X)}] set dy [expr {$Y - $drag(Y)}] wm geometry $win +$dx+$dy } elseif {$edge(at) == $edge(left)} { # need to handle moving root - currently just moves set dx [expr {$X - $drag(X)}] set dy [expr {$Y - $drag(Y)}] wm geometry $win +$dx+$dy } elseif {$edge(at) == $edge(right)} { set relx [expr {$X - [winfo rootx $win]}] set width [expr {$relx - $drag(X) + $drag(w)}] set height $drag(h) if {$width > 5} { wm geometry $win ${width}x${height} } } elseif {$edge(at) == $edge(top)} { # need to handle moving root - currently just moves set dx [expr {$X - $drag(X)}] set dy [expr {$Y - $drag(Y)}] wm geometry $win +$dx+$dy } elseif {$edge(at) == $edge(bottom)} { set rely [expr {$Y - [winfo rooty $win]}] set width $drag(w) set height [expr {$rely - $drag(Y) + $drag(h)}] if {$height > 5} { wm geometry $win ${width}x${height} } } } } ######################################## ## Ready for use package provide widget::ruler 1.2 package provide widget::screenruler 1.3 if {[info exist ::argv0] && $::argv0 eq [info script]} { # We are the main script being run - show ourselves wm withdraw . set dlg [widget::screenruler .r -grid 1 -title "Screen Ruler"] $dlg menu add separator $dlg menu add command -label "Exit" -command { exit } $dlg display } tcltk2/inst/tklibs/widget3.2/statusbar.tcl0000644000176200001440000001753115017041713020152 0ustar liggesusers# -*- tcl -*- # # statusbar.tcl - # Create a status bar Tk widget # # RCS: @(#) $Id: statusbar.tcl,v 1.8 2010/06/01 18:06:52 hobbs Exp $ # # Creation and Options - widget::scrolledwindow $path ... # # -separator -default 1 ; show horizontal separator on top of statusbar # -resize -default 1 ; show resize control on bottom right # -resizeseparator -default 1 ; show separator for resize control # ## Padding can be a list of {padx pady} # -ipad -default 1 ; provides padding around each status bar item # -pad -default 0 ; provides general padding around the status bar # # All other options to frame # # Methods # $path getframe => $frame # $path add $widget ?args? => $widget # All other methods to frame # # Bindings # NONE # # Provides a status bar to be placed at the bottom of a toplevel. # Currently does not support being placed in a toplevel that has # gridding applied (via widget -setgrid or wm grid). # # Ensure that the widget is placed at the very bottom of the toplevel, # otherwise the resize behavior may behave oddly. # package require widget if {0} { proc sample {} { # sample usage eval destroy [winfo children .] pack [text .t -width 0 -height 0] -fill both -expand 1 set sbar .s widget::statusbar $sbar pack $sbar -side bottom -fill x set f [$sbar getframe] # Specify -width 1 for the label widget so it truncates nicely # instead of requesting large sizes for long messages set w [label $f.status -width 1 -anchor w -textvariable ::STATUS] set ::STATUS "This is a status message" # give the entry weight, as we want it to be the one that expands $sbar add $w -weight 1 # BWidget's progressbar set w [ProgressBar $f.bpbar -orient horizontal \ -variable ::PROGRESS -bd 1 -relief sunken] set ::PROGRESS 50 $sbar add $w } } snit::widget widget::statusbar { hulltype ttk::frame component resizer component separator component sepresize component frame # -background, -borderwidth and -relief apply to outer frame, but relief # should be left flat for proper look delegate option * to hull delegate method * to hull option -separator -default 1 -configuremethod C-separator \ -type [list snit::boolean] option -resize -default 1 -configuremethod C-resize \ -type [list snit::boolean] option -resizeseparator -default 1 -configuremethod C-resize \ -type [list snit::boolean] # -pad provides general padding around the status bar # -ipad provides padding around each status bar item # Padding can be a list of {padx pady} option -ipad -default 2 -configuremethod C-ipad \ -type [list snit::listtype -type {snit::integer} -minlen 1 -maxlen 4] delegate option -pad to frame as -padding variable ITEMS -array {} variable uid 0 constructor args { $hull configure -height 18 install frame using ttk::frame $win.frame install resizer using ttk::sizegrip $win.resizer install separator using ttk::separator $win.separator \ -orient horizontal install sepresize using ttk::separator $win.sepresize \ -orient vertical grid $separator -row 0 -column 0 -columnspan 3 -sticky ew grid $frame -row 1 -column 0 -sticky news grid $sepresize -row 1 -column 1 -sticky ns;# -padx $ipadx -pady $ipady grid $resizer -row 1 -column 2 -sticky se grid columnconfigure $win 0 -weight 1 $self configurelist $args } method C-ipad {option value} { set options($option) $value # returns pad values - each will be a list of 2 ints foreach {px py} [$self _padval $value] { break } foreach w [grid slaves $frame] { if {[string match _sep* $w]} { grid configure $w -padx $px -pady 0 } else { grid configure $w -padx $px -pady $py } } } method C-separator {option value} { set options($option) $value if {$value} { grid $separator } else { grid remove $separator } } method C-resize {option value} { set options($option) $value if {$options(-resize)} { if {$options(-resizeseparator)} { grid $sepresize } grid $resizer } else { grid remove $sepresize $resizer } } # Use this or 'add' - but not both method getframe {} { return $frame } method add {what args} { if {[winfo exists $what]} { set w $what set symbol $w set ours 0 } else { set w $frame._$what[incr uid] set symbol [lindex $args 0] set args [lrange $args 1 end] if {![llength $args] || $symbol eq "%AUTO%"} { # Autogenerate symbol name set symbol _$what$uid } if {[info exists ITEMS($symbol)]} { return -code error "item '$symbol' already exists" } if {$what eq "label" || $what eq "button" || $what eq "checkbutton" || $what eq "radiobutton"} { set w [ttk::$what $w -style Toolbutton -takefocus 0] } elseif {$what eq "separator"} { set w [ttk::separator $w -orient vertical] } elseif {$what eq "space"} { set w [ttk::frame $w] } else { return -code error "unknown item type '$what'" } set ours 1 } set opts(-weight) [string equal $what "space"] set opts(-separator) 0 set opts(-sticky) news set opts(-pad) $options(-ipad) if {$what eq "separator"} { # separators should not have pady by default lappend opts(-pad) 0 } set cmdargs [list] set len [llength $args] for {set i 0} {$i < $len} {incr i} { set key [lindex $args $i] set val [lindex $args [incr i]] if {$key eq "--"} { eval [list lappend cmdargs] [lrange $args $i end] break } if {[info exists opts($key)]} { set opts($key) $val } else { # no error - pass to command lappend cmdargs $key $val } } if {[catch {eval [linsert $cmdargs 0 $w configure]} err]} { # we only want to destroy widgets we created if {$ours} { destroy $w } return -code error $err } set ITEMS($symbol) $w widget::isa listofint 4 -pad $opts(-pad) # returns pad values - each will be a list of 2 ints foreach {px py} [$self _padval $opts(-pad)] { break } # get cols,rows extent foreach {cols rows} [grid size $frame] break # Add separator if requested, and we aren't the first element if {$opts(-separator) && $cols != 0} { set sep [ttk::separator $frame._sep[winfo name $w] \ -orient vertical] # No pady for separators, and adjust padx for separator space set sx $px if {[lindex $sx 0] < 2} { lset sx 0 2 } lset px 1 0 grid $sep -row 0 -column $cols -sticky ns -padx $sx -pady 0 incr cols } grid $w -in $frame -row 0 -column $cols -sticky $opts(-sticky) \ -padx $px -pady $py grid columnconfigure $frame $cols -weight $opts(-weight) return $symbol } method remove {args} { set destroy [string equal [lindex $args 0] "-destroy"] if {$destroy} { set args [lrange $args 1 end] } foreach sym $args { # Should we ignore unknown (possibly already removed) items? #if {![info exists ITEMS($sym)]} { continue } set w $ITEMS($sym) # separator name is based off item name set sep $frame._sep[winfo name $w] # destroy separator for remove or destroy case destroy $sep if {$destroy} { destroy $w } else { grid forget $w } unset ITEMS($sym) } } method delete {args} { eval [linsert $args 0 $self remove -destroy] } method items {{ptn *}} { # return from ordered list if {$ptn ne "*"} { return [array names ITEMS $ptn] } return [array names ITEMS] } method _padval {val} { set len [llength $val] if {$len == 0} { return [list 0 0 0 0] } elseif {$len == 1} { return [list [list $val $val] [list $val $val]] } elseif {$len == 2} { set x [lindex $val 0] ; set y [lindex $val 1] return [list [list $x $x] [list $y $y]] } elseif {$len == 3} { return [list [list [lindex $val 0] [lindex $val 2]] \ [list [lindex $val 1] [lindex $val 1]]] } else { return $val } } } package provide widget::statusbar 1.2.1 tcltk2/inst/tklibs/widget3.2/pkgIndex.tcl0000644000176200001440000000243615017041713017711 0ustar liggesusersif {![package vsatisfies [package provide Tcl] 8.4-]} {return} package ifneeded widget 3.2 [list source [file join $dir widget.tcl]] package ifneeded widget::arrowbutton 1.0 [list source [file join $dir arrowb.tcl]] package ifneeded widget::calendar 1.0.2 [list source [file join $dir calendar.tcl]] package ifneeded widget::dateentry 0.98 [list source [file join $dir dateentry.tcl]] package ifneeded widget::dialog 1.3.1 [list source [file join $dir dialog.tcl]] package ifneeded widget::menuentry 1.0.1 [list source [file join $dir mentry.tcl]] package ifneeded widget::panelframe 1.1 [list source [file join $dir panelframe.tcl]] package ifneeded widget::ruler 1.2 [list source [file join $dir ruler.tcl]] package ifneeded widget::screenruler 1.3 [list source [file join $dir ruler.tcl]] package ifneeded widget::scrolledtext 1.0 [list source [file join $dir stext.tcl]] package ifneeded widget::scrolledwindow 1.2.1 [list source [file join $dir scrollw.tcl]] package ifneeded widget::statusbar 1.2.1 [list source [file join $dir statusbar.tcl]] package ifneeded widget::superframe 1.0.1 [list source [file join $dir superframe.tcl]] package ifneeded widget::toolbar 1.2.1 [list source [file join $dir toolbar.tcl]] tcltk2/inst/tklibs/widget3.2/panelframe.tcl0000644000176200001440000001473115017041713020253 0ustar liggesusers# -*- tcl -*- # # panelframe.tcl # Create PanelFrame widgets. # A PanelFrame is a boxed frame that allows you to place items # in the label area (liked combined frame+toolbar). It uses the # highlight colors the default frame color. # # Scrolled widget # # Copyright 2005 Jeffrey Hobbs # # RCS: @(#) $Id: panelframe.tcl,v 1.6 2010/06/01 18:06:52 hobbs Exp $ # if 0 { # Samples lappend auto_path ~/cvs/tcllib/tklib/modules/widget package require widget::panelframe set f [widget::panelframe .pf -text "My Panel"] set sf [frame $f.f -padx 4 -pady 4] pack [text $sf.text] -fill both -expand 1 $f setwidget $sf pack $f -fill both -expand 1 -padx 4 -pady 4 } ### package require widget namespace eval widget { variable entry_selbg variable entry_selfg if {![info exists entry_selbg]} { set entry_selbg [widget::tkresource entry -selectbackground] if {$entry_selbg eq ""} { set entry_selbg "black" } set entry_selfg [widget::tkresource entry -selectforeground] if {$entry_selfg eq ""} { set entry_selfg "black" } } snit::macro widget::entry-selectbackground {} [list return $entry_selbg] snit::macro widget::entry-selectforeground {} [list return $entry_selfg] variable imgdata { #define close_width 16 #define close_height 16 static char close_bits[] = { 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x10, 0x08, 0x38, 0x1c, 0x70, 0x0e, 0xe0, 0x07, 0xc0, 0x03, 0xc0, 0x03, 0xe0, 0x07, 0x70, 0x0e, 0x38, 0x1c, 0x10, 0x08, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; } # We use the same -foreground as the default image create bitmap ::widget::X -data $imgdata -foreground $entry_selfg } snit::widget widget::panelframe { hulltype frame ; # not themed component title component tframe #component frame #component close delegate option * to hull delegate method * to hull widget::propagate {-panelbackground panelBackground Background} \ -default [widget::entry-selectbackground] to {hull title tframe} \ as -background widget::propagate {-panelforeground panelForeground Foreground} \ -default [widget::entry-selectforeground] to {title} \ as -foreground # type listof 1..4 int option -ipad -default 1 -configuremethod C-ipad # should we use this instead of setwidget? #option -window -default "" -configuremethod C-window ; # -isa window # The use of a bold font by default would be better delegate option -font to title delegate option -text to title delegate option -textvariable to title # Should we have automatic state handling? #option -state -default normal if 0 { # This would be code to have an automated close button option -closebutton -default 0 -configuremethod C-closebutton } variable items {} ; # items user has added constructor args { $hull configure -borderwidth 1 -relief flat \ -background $options(-panelbackground) install tframe using frame $win.title \ -background $options(-panelbackground) install title using label $win.title.label -anchor w -bd 0 \ -background $options(-panelbackground) \ -foreground $options(-panelforeground) # does it need to be a ttk::frame ? #install frame using ttk::frame $win.frame foreach {ipadx ipady} [$self _padval $options(-ipad)] { break } if 0 { install close using button $tframe.close -image ::widget::X \ -padx 0 -pady 0 -relief flat -overrelief raised \ -bd 1 -highlightthickness 0 \ -background $options(-panelbackground) \ -foreground $options(-panelforeground) #$close configure -font "Marlett -14" -text \u0072 if {$options(-closebutton)} { pack $close -side right -padx $ipadx -pady $ipady } } grid $tframe -row 0 -column 0 -sticky ew #grid $frame -row 1 -column 0 -sticky news grid columnconfigure $win 0 -weight 1 grid rowconfigure $win 1 -weight 1 #grid columnconfigure $frame 0 -weight 1 #grid rowconfigure $frame 0 -weight 1 pack $title -side left -fill x -anchor w -padx $ipadx -pady $ipady $self configurelist $args } method C-ipad {option value} { set len [llength $value] foreach {a b} $value { break } if {$len == 0 || $len > 2} { return -code error \ "invalid pad value \"$value\", must be 1 or 2 pixel values" } pack configure $title -padx $ipadx -pady $ipady set options($option) $value } if 0 { method C-closebutton {option value} { if {$value} { foreach {ipadx ipady} [$self _padval $options(-ipad)] { break } pack $close -side right -padx $ipadx -pady $ipady } else { pack forget $close } set options($option) $value } } # We could create and extra frame and return it, but in order to # not decide whether that is a ttk or regular frame, just force # the user to use setwidget instead #method getframe {} { return $frame } variable setwidget {} method setwidget {w} { if {[winfo exists $setwidget]} { grid remove $setwidget set setwidget {} } if {[winfo exists $w]} { grid $w -in $win -row 1 -column 0 -sticky news set setwidget $w } } method add {w args} { array set opts [list \ -side right \ -fill none \ -expand 0 \ -pad $options(-ipad) \ ] foreach {key val} $args { if {[info exists opts($key)]} { set opts($key) $val } else { set msg "unknown option \"$key\", must be one of: " append msg [join [lsort [array names opts]] {, }] return -code error $msg } } foreach {ipadx ipady} [$self _padval $opts(-pad)] { break } lappend items $w pack $w -in $tframe -padx $ipadx -pady $ipady -side $opts(-side) \ -fill $opts(-fill) -expand $opts(-expand) return $w } method remove {args} { set destroy [string equal [lindex $args 0] "-destroy"] if {$destroy} { set args [lrange $args 1 end] } foreach w $args { set idx [lsearch -exact $items $w] if {$idx == -1} { # ignore unknown continue } if {$destroy} { destroy $w } elseif {[winfo exists $w]} { pack forget $w } set items [lreplace $items $idx $idx] } } method delete {args} { return [$self remove -destroy $args] } method items {} { return $items } method _padval {padval} { set len [llength $padval] foreach {a b} $padval { break } if {$len == 0 || $len > 2} { return -code error \ "invalid pad value \"$padval\", must be 1 or 2 pixel values" } elseif {$len == 1} { return [list $a $a] } elseif {$len == 2} { return $padval } } } package provide widget::panelframe 1.1 tcltk2/inst/tklibs/widget3.2/ChangeLog0000644000176200001440000003446015017041713017210 0ustar liggesusers2020-02-09 0.7 * * Released and tagged Tklib 0.7 ======================== * 2013-03-25 Andreas Kupries * * Released and tagged Tklib 0.6 ======================== * 2013-03-13 Andreas Kupries * calendar.tcl: [Bug 3458158, 3607261]: Fixed broken bindings of * dateentry.tcl: "widget::calendar" which in turn broke "widget::dateentry". * pkgIndex.tcl: Bumped calendar to 1.0.1, dateentry to 0.96. 2011-12-13 Ruediger Haertel * pkgIndex.tcl: Bumped package version to 0.95. * widget_dateentry.tcl: * dateentry.tcl: - Bugfix:3458158, Adopt to changes of calendar v1.00 - Provide a man page 2011-11-16 Ruediger Haertel * pkgIndex.tcl: Bumped package version to 1.00. * widget_calendar.tcl: * calendar.tcl: - Update -textvariable and call -command when navigated by keyboard. - Refactored code so that mouse button select and keyboard navigation use the same code - Added key binding for the Home key. 2011-11-16 Andreas Kupries * dateentry.tcl: Added option -language, using the patch provided * pkgIndex.tcl: by J. Lewandowski . Bumped package version to 0.94. 2011-10-31 Andreas Kupries * calendar.tcl (C-language): Extended to include 'pl' (Polish) as * pkgIndex.tcl: viable language, per J. Lewandowski. Bumped * widget_calendar.man: version to 0.98. 2011-09-12 Andreas Kupries * calendar.tcl: Added polish language definitions sent in * pkgIndex.tcl: by J. Lewandowski. Bumped version to 0.97. * widget_calendar.man: 2010-09-30 Ruediger Haertel * calendar.tcl: allow a -textvariable also from the dateentry namespace. This was a misconception from their beginning. * pkgIndex.tcl: bump calendar to v0.96 2010-09-28 Jeff Hobbs * pkgIndex.tcl: Bump dateentry to 0.93 * dateentry.tcl: address aqua issues causing selection not to work, following ttk::combobox. Do grab/release on popdown Map/Unmap and focus on calendar Map. Set wm transient/group only on non-aqua wms. 2010-07-15 Jeff Hobbs * pkgIndex.tcl: bump calendar to 0.95 * calendar.tcl (Refresh): use correct last day, as 8.4 doesn't handle going over on days in month for clock scan. 2010-07-09 Andreas Kupries * arrowb.tcl: Added arrowbutton widgets using Keith Vetter's * pkgIndex.tcl: bitmaps (see http://wiki.tcl.tk/8554). Bumped widget::all version to 1.2.2. 2010-06-02 Andreas Kupries * pkgIndex.tcl: Meh, typo'd my update. screenruler is unchanged, scrolledwindow isn't. Fixed. 2010-06-01 Andreas Kupries * pkgIndex.tcl: Updated with the actual package versions. 2010-06-01 Jeff Hobbs * dateentry.tcl: v0.92 * dialog.tcl: v1.3.1 * mentry.tcl: v1.0.1 * statusbar.tcl: v1.2.1 * superframe.tcl: v1.0.1 * scrollw.tcl: v1.2.1 * toolbar.tcl: v1.2.1 rely on widget to provide tile * widget.tcl: v3.1 conditionally require tile (8.4 only) 2009-09-25 Ruediger Haertel * calendar.tcl: handle -textvariable option correctly also for variables in namespaces * pkgIndex.tcl: bump calendar to v0.94 2009-09-25 Ruediger Haertel * calendar.tcl: uninstall trace handler whenever a new textvariable is assigned . remove bugfix in key bindings which resulted in an Tcl Error * pkgIndex.tcl: really bump calendar to v0.93 2009-09-25 Ruediger Haertel * calendar.tcl: uninstall trace handler with dtor . create key bindings to move within the calendar. . changing the language immediately refreshes the widget. . for english and german the string "Today is" is displayed, other languages don't have this. * widget_calendar.tcl: added section with key bindings * pkgIndex.tcl: bump calendar to v0.93 2009-09-25 Ruediger Haertel * calendar.tcl: install/uninstall trace handler when -textvariable is set/unset * pkgIndex.tcl: bump calendar to v0.92 2009-08-17 Jeff Hobbs * calendar.tcl: correct leading 0-month issues. Make 8.4-friendly by not needing clock scan -format. * pkgIndex.tcl: bump calendar to v0.91 2009-01-21 Andreas Kupries * * Released and tagged Tklib 0.5 ======================== * 2008-11-23 Ruediger Haertel * widget_calendar.man: added documentation to widget::calendar 2008-11-23 Ruediger Haertel * widget.man: added widget::calendar and widget::dateentry to the overview of snidgets in this package 2008-11-13 Jeff Hobbs * pkgIndex.tcl: widget::calendar 0.9 ; widget::dataentry 0.91 * calendar.tcl: new widget::calendar adapted from the dateentry dropbox pieces. Now can be used as a stand-alone widget. * dateentry.tcl: update to use calendar widget in dropbox. 2008-11-12 Jeff Hobbs * pkgIndex.tcl: add widget::dateentry 0.9 * dateentry.tcl: first pass at a dateentry dropbox, by Ruediger Haertel with updates from JH. 2008-06-17 Jeff Hobbs * pkgIndex.tcl: bump panelframe to 1.1. * panelframe.tcl: handle the case of empty color names (occurs on OS X) for use of fg/bg. 2008-02-21 Jeff Hobbs * pkgIndex.tcl: bump widget::screenruler to 1.2 * ruler.tcl (C-showgeometry): prevent entry input from triggering the toplevel bindings. 2007-06-20 Jeff Hobbs * statusbar.tcl: update to 1.2, actual API changes (matched closer to toolbar), but they were not documented previously. The core API remains and should be compatible with most standard use cases. Remove fallback sizegrip image usage, requires ttk::sizegrip now. update option handling with latest snit features. * toolbar.tcl (add): update to 1.2 update option handling with latest snit features. Pass -pad to frame. Rename 'itemidentify' to 'itemid'. * stext.tcl (new): example adaptation of scrolledwindow to create a scrolledtext widget. * ruler.tcl: update to 1.1 Correct zoom menu to show proper label. update option handling with latest snit features. * scrollw.tcl: update to 1.2 update option handling with latest snit features. Use ttk::scrollbar on Windows (just not on Aqua). Correctly handle widgets with 1-dim scrolling. rework auto-handling of scrollbars. 2007-04-10 Jeff Hobbs * scrollw.tcl: cancel pending timer in case we are destroyed * mentry.tcl (::widget::createMenuEntryLayout): handle variant style cmd usage for 8.4 and 8.5+. 2007-03-01 Jeff Hobbs * dialog.tcl (C-transient, C-parent): ensure we unset parent transient and group when not both are set. 2007-01-30 Andreas Kupries * toolbar.tcl (itemidentify): New method, converting symbolic button names to their actual widget path. * toolbar.tcl (items): Simplified the code. 2007-01-21 Jeff Hobbs * scrollw.tcl (_set_scroll): move loop lock detection to include removal of scrollbar 2006-12-05 Jeff Hobbs * dialog.tcl (PlaceWindow): handle unmapped anchor 2006-11-27 Jeff Hobbs * dialog.tcl (PlaceWindow): always raise after deiconify 2006-11-15 Jeff Hobbs * ruler.tcl: add screenruler menu bindings and underlines 2006-11-03 Jeff Hobbs * dialog.tcl (display): init lastFocusGrab properly don't restore focus/grab if we weren't mapped 2006-11-02 Jeff Hobbs * dialog.tcl: add -focus option to set desired subwindow focus, and make sure we don't restore focus/grab to a subwindow on withdraw 2006-10-27 Jeff Hobbs * dialog.tcl (display): don't tkwait, as it will just hang for an already displayed window (a Tk misfeature ... but oh well). 2006-10-19 Jeff Hobbs * dialog.tcl: handle -separator changed with option default 2006-10-01 Jeff Hobbs * dialog.tcl (withdraw): fix grab handling to properly release 2006-09-29 Jeff Hobbs * scrollw.tcl: fix error gridding scrollbar from 2006-09-25 change to handle the variant options for vsb vs. hsb correctly. 2006-09-26 Jeff Hobbs * toolbar.tcl (add): separator item should have no pady by default (add): add label and radiobutton item support 2006-09-25 Jeff Hobbs * scrollw.tcl: consolidate scroll handling to one method. Add extra check for loop condition (last min/max). 2006-09-22 Jeff Hobbs * dialog.tcl (display): correct handling of -modal == local 2006-09-07 Andreas Kupries * widget_toolbar.man: Fixed missing closing bracket. * pkgIndex.tcl (::tcl::pkgindex): Reworked the 'pkindex' command to make it more general, and more susceptible to programmatic analysis (meta data extraction). 2006-09-07 Jeff Hobbs * widget.tcl (::widget::isa): correct error result for 'isa list' * widget.man: include all current widgets * widget_toolbar.man: man page for widget::toolbar * pkgIndex.tcl (::widget::pkgindex): made pkgindex to consolidate commands for widget::all more easily * toolbar.tcl: allow for '$tbar add separator'. allow for %AUTO% as name in special-purpose add types. ensure we only delete toolbar-created widgets on add error. check for item existence in itemcget. add '$tbar add space' for a spacer item. 2006-08-24 Jeff Hobbs * statusbar.tcl: use ttk::sizegrip if available. * pkgIndex.tcl: update statusbar to 1.1. 2006-08-02 Jeff Hobbs * panelframe.tcl (add): correct call to _padval. [Bug #1522881] 2006-07-05 Jeff Hobbs * dialog.tcl (setwidget): configure frame resizability only if we setwidget into it. It confuses use with getframe. 2006-06-29 Jeff Hobbs * mentry.tcl: update the icon with a better drop arrow (::widget::createMenuEntryLayout): simplify theme settings * statusbar.tcl (add): remove neighboring separator when removing the first item. * dialog.tcl (PlaceWindow): add a raise after deiconify. 2006-06-22 Jeff Hobbs * mentry.tcl: use Ctrl-space for popdown key (was Key-Space). * statusbar.tcl (C-ipad): allow 4-int -(i)pad, make default -ipad 2. Ensure minimum separator spacing and adjust item padding for sep. * toolbar.tcl (C-ipad): allow 4-int -(i)pad, make default -ipad 2. Ensure minimum separator spacing and adjust item padding for sep. Correct adding of typed items. * widget.tcl (::widget::isa): correct listofint range handling 2006-06-21 Jeff Hobbs * mentry.tcl: new image with drop-arrow and improved padding 2006-06-20 Jeff Hobbs * mentry.tcl: prototype menuentry widget (entry with associated * pkgIndex.tcl: menu under an icon). * pkgIndex.tcl: * toolbar.tcl: add widget::toolbar that eases toolbar handling * statusbar.tcl: s/-show/-/ in option names. Make -separator default to 0 for add items. 2006-06-19 Jeff Hobbs * statusbar.tcl: add widget::statusbar, equivalent to BWidget * pkgIndex.tcl: StatusBar widget. * scrollw.tcl: remove widget::tscrolledwindow, make widget::scrolledwindow use a ttk::frame, bump to 1.1. 2006-06-15 Jeff Hobbs * scrollw.tcl: support scrollbar actually being a ttk::scrollbar. 2006-06-06 Andreas Kupries * scrollw.tcl: Added provide statement for 'tscrolledwindow'. 2006-06-05 Jeff Hobbs * ruler.tcl: make sure reflect(id) gets cancelled * scrollw.tcl: added ttk scrolledwindow variant * pkgIndex.tcl: added widget::tscrolledwindow 2005-11-10 Andreas Kupries * * Released and tagged Tklib 0.4.1 ======================== * 2005-11-02 Andreas Kupries * * Released and tagged Tklib 0.4 ======================== * 2005-10-12 Jeff Hobbs * pkgIndex.tcl: Bumped widget::dialog to v1.2. * dialog.tcl: allow -type custom dialogs to be synchronous, add an example showing user how to use it properly. 2005-09-26 Jeff Hobbs * pkgIndex.tcl: bumped widget::screenruler to 1.1 * ruler.tcl: fix off-by-one drawing in ruler and let the loupe auto-center around the pointer for us. 2005-09-25 Jeff Hobbs * ruler.tcl: add -zoom option, add proper destructors, make -measure work, add -reflect option to screenruler. Add -showgeometry to control geometry strictly. * dialog.tcl: add docs * scrollw.tcl: change non-working -padding to working -ipad 2005-09-21 Jeff Hobbs * widget.man, pkgIndex.tcl, ruler.tcl: add widget::ruler widget and widget::screenruler dialog 2005-09-12 Jeff Hobbs * scrollw.tcl: move tk call after 'package require widget' 2005-09-08 Jeff Hobbs * dialog.tcl: add -timeout ms option to dialog * scrollw.tcl: use ttk::scrollbar on x11 2005-08-25 Jeff Hobbs * dialog.tcl: don't require 'name' in dialog button add, allow widget pathnames to be inserted, up to v1.1 2005-08-22 Jeff Hobbs * widget.tcl: add widget::tkresource to get default class options. add widget::propagate snit macro to do multi-component propagation. * panelframe.tcl: widget::panelframe to create color-bordered frames. This could be part of superframe, but then superframe would need extra widgets * widget.tcl: new megawidget package, based on snit (snidgets) * widget.man: * pkgIndex.tcl: * dialog.tcl: widget::dialog megawidget dialog * superframe.tcl: widget::superframe enhanced frame types * scrollw.tcl: widget::scrolledwindow BWidget::ScrolledWindow port tcltk2/inst/tklibs/widget3.2/dateentry.tcl0000644000176200001440000002612215017041713020135 0ustar liggesusers# -*- tcl -*- # # dateentry.tcl - # # dateentry widget # # This widget provides an entry with a visual calendar for # choosing a date. It is mostly a gathering compoments. # # The basics for the entry were taken from the "MenuEntry widget" # of the widget package in the tklib. # The visual calendar is taken from http://wiki.tcl.tk/1816. # # So many thanks to Richard Suchenwirth for visual calendar # and to Jeff Hobbs for the widget package in tklib. # # See the example at the bottom. # # Creation and Options - widget::dateentry $path ... # -command -default {} # -dateformat -default "%m/%d/%Y" # -font -default {Helvetica 9} # -background -default white # -textvariable -default {} -configuremethod C-textvariable # # Following are passed to widget::calendar component: # -firstday # -highlightcolor # -language # # Methods # $widget post - display calendar dropdown # $widget unpost - remove calendar dropdown # All other methods to entry # # Bindings # NONE # ### package require widget package require widget::calendar namespace eval ::widget { # http://www.famfamfam.com/lab/icons/mini/ # ?Mini? is a set of 144 GIF icons available for free use for any purpose. variable dateentry_gifdata { R0lGODlhEAAQAMQAANnq+K7T5HiUsMHb+v/vlOXs9IyzzHWs1/T5/1ZtjUlVa+z1/+3 x9uTx/6a2ysng+FFhe0NLXIDG/fD4/ykxQz5FVf/41vr8/6TI3MvM0XHG/vbHQPn8// b8/4PL/f///yH5BAAAAAAALAAAAAAQABAAAAWV4Cdam2h+5AkExCYYsCC0iSAGTisAP JC7kNvicPBIjkeiIyHCMDzQaFRTYH4wBY6W0+kgvpNC8GNgXLhd8CQ8Lp8f3od8sSgo RIasHPGY0AcNdiIHBV0PfHQNgAURIgKFfBMPCw2KAIyOkH0LA509FY4TXn6UDT0MoB8 JDwwFDK+wrxkUjgm2EBAKChERFRUUYyfCwyEAOw== } # http://www.famfamfam.com/lab/icons/silk/ # ?Silk? is a smooth, free icon set, variable dateentry_gifdata { R0lGODlhEAAQAPZ8AP99O/9/PWmrYmytZW6uaHOxbP+EQv+LR/+QTf+UUv+VVP+WVP+ YV/+ZWP+aWv+dXP+eXf+fX/+nVP+rWv+gYP+hYf+iYv+jZP+kZP+kZf+wYf+zaP+4bf +5cf+7df+9eUJ3u1KEw1SGxFWGxlaHx12KxVyKxl+MxlmKyFuKyV+NyF6Oy1+Py2OSz mSTzmiW0WqX0W6Z02+b1HKe1nSg13Wh13qj2nqk2X2l3H6o3ZHBjJvHlqXNoa/Sq4Cp 3YOr3IKq34mu2Yyw24mw3pG03Za434Ss4Ieu4Yiv4oyx44+14Yyy5I+05ZC15pO355S 355W445294Zq75p++5pa66Zi66Zq865u9652+656/7KG/55/A7aTB5KTB56vG5abD6a HB7qLB76rG6a7J6rLL6rfO6rrQ67zQ68PdwNfp1dji8Nvk8d7n8t7n8+Lq9Obt9urw9 +vx9+3y+O7z+e/z+fD0+vH2+vL2+vT3+/n8+f7+/v7//v///wAAAAAAAAAAACH5BAEA AH0ALAAAAAAQABAAAAfMgH2Cg4SFg2FbWFZUTk1LSEY+ODaCYHiXmJmXNIJZeBkXFBA NCwgHBgF4MoJXeBgfHh0cGxoTEgB4MIJVnxcWFREPDgwKCXgugk94X3zNzs1ecSyCTH difD0FaT0DPXxcbCiCSXZjzQJpO3kFfFFqI4JHdWTnaTp8AnxFaiKCQHRl+KARwKMHA W9E1KgQlIOOGT569uyB2EyIGhOCbsw500XLFClQlAz5EUTNCUE15MB546bNGjUwY5YQ NCPGixYrUpAIwbMnCENACQUCADs= } } proc ::widget::createdateentryLayout {} { variable dateentry if {[info exists dateentry]} { return } set dateentry 1 variable dateentry_pngdata variable dateentry_gifdata set img ::widget::img_dateentry image create photo $img -format GIF -data $dateentry_gifdata namespace eval ::ttk [list set dateimg $img] ; # namespace resolved namespace eval ::ttk { # Create -padding for space on left and right of icon set pad [expr {[image width $dateimg] + 6}] style theme settings "default" { style layout dateentry { Entry.field -children { dateentry.icon -side left Entry.padding -children { Entry.textarea } } } # center icon in padded cell style element create dateentry.icon image $dateimg \ -sticky "" -padding [list $pad 0 0 0] } if 0 { # Some mappings would be required per-theme to adapt to theme # changes foreach theme [style theme names] { style theme settings $theme { # Could have disabled, pressed, ... state images #style map dateentry -image [list disabled $img] } } } } } snit::widgetadaptor widget::dateentry { delegate option * to hull delegate method * to hull option -command -default {} option -dateformat -default "%m/%d/%Y" -configuremethod C-passtocalendar option -font -default {Helvetica 9} -configuremethod C-passtocalendar option -textvariable -default {} -configuremethod C-textvariable option -language -default en -configuremethod C-passtocalendar delegate option -highlightcolor to calendar delegate option -shadecolor to calendar delegate option -firstday to calendar delegate option -showpast to calendar component dropbox component calendar variable formattedDate ;# Chosen date, formatted, linked to calendar, shown in entry variable rawDate ;# Same, as seconds. variable startOnMonday 1 ;# !! Unused constructor args { ::widget::createdateentryLayout installhull using ttk::entry -style dateentry bindtags $win [linsert [bindtags $win] 1 TDateEntry] $self MakeCalendar $self configurelist $args # Initialize entry to current date, midnight set rawDate [expr {([clock seconds] / 86400) * 86400}] set formattedDate [clock format $rawDate -format $options(-dateformat)] $self UpdateEntry } destructor { # Drop link to outer textvariable $self configure -textvariable {} } method C-passtocalendar {option value} { set options($option) $value $calendar configure $option $value } method C-textvariable {option value} { if {$options(-textvariable) ne {}} { trace remove variable $options(-textvariable) write [mymethod DateSet] } set options($option) $value if {$options(-textvariable) ne {}} { trace add variable $options(-textvariable) write [mymethod DateSet] } } method MakeCalendar {args} { set dropbox $win.__drop destroy $dropbox toplevel $dropbox -takefocus 0 wm withdraw $dropbox if {[tk windowingsystem] ne "aqua"} { wm overrideredirect $dropbox 1 wm transient $dropbox [winfo toplevel $win] wm group $dropbox [winfo parent $win] } else { tk::unsupported::MacWindowStyle style $dropbox \ help {noActivates hideOnSuspend} } wm resizable $dropbox 0 0 # Unpost on Escape or whenever user clicks outside the dropdown bind $dropbox [list $win unpost] bind $dropbox [subst -nocommands { if {[string first "$dropbox" [winfo containing %X %Y]] != 0} { $win unpost } }] bindtags $dropbox [linsert [bindtags $dropbox] 1 TDateEntryPopdown] set calendar $dropbox.calendar widget::calendar $calendar \ -textvariable [myvar formattedDate] \ -dateformat $options(-dateformat) \ -font $options(-font) \ -language $options(-language)\ -borderwidth 1 \ -relief solid \ -enablecmdonkey 0 \ -command [mymethod DateChosen] bind $calendar [list focus -force $calendar] pack $calendar -expand 1 -fill both return $dropbox } method set {date} { # Run the incoming value through scan to ensure that it has the proper format. set rawDate [clock scan $date -format $options(-dateformat)] set formattedDate [clock format $rawDate -format $options(-dateformat)] $self UpdateEntry return } method post { args } { # TODO TCL 8.5+: `"disabled" in [$self state]` if {[lsearch -exact [$self state] "disabled"] >= 0} { return } # XXX should we reset date on each display? if {![winfo exists $dropbox]} { $self MakeCalendar } foreach {x y} [$self PostPosition] { break } wm geometry $dropbox "+$x+$y" wm deiconify $dropbox raise $dropbox if {[tk windowingsystem] ne "aqua"} { tkwait visibility $dropbox } focus -force $calendar return } method unpost {args} { if {![winfo exists $dropbox]} return wm withdraw $dropbox grab release $dropbox ; # just in case return } method PostPosition {} { # PostPosition -- # Returns the x and y coordinates where the menu # should be posted, based on the dateentry and menu size # and -direction option. # # TODO: adjust menu width to be at least as wide as the button # for -direction above, below. # set x [winfo rootx $win] set y [winfo rooty $win] set dir "below" ; #[$win cget -direction] set bw [winfo width $win] set bh [winfo height $win] set mw [winfo reqwidth $dropbox] set mh [winfo reqheight $dropbox] set sw [expr {[winfo screenwidth $dropbox] - $bw - $mw}] set sh [expr {[winfo screenheight $dropbox] - $bh - $mh}] switch -- $dir { above { if {$y >= $mh} { incr y -$mh } { incr y $bh } } below { if {$y <= $sh} { incr y $bh } { incr y -$mh } } left { if {$x >= $mw} { incr x -$mw } { incr x $bw } } right { if {$x <= $sw} { incr x $bw } { incr x -$mw } } } return [list $x $y] } # # DateChosen -- # # Called from the calendar when a date was selected. # # Formats the date, calls the callback -command if specified and # then updates the entry. # ## method DateChosen { args } { $self UpdateEntry # synch raw date - Ensures that chosen format is held to set rawDate [clock scan $formattedDate -format $options(-dateformat)] # Export to linked variable upvar 0 $options(-textvariable) date set date $formattedDate # Export via callback $self CallCommand $self unpost return } # Handle changes to the contents of the linked -textvariable method DateSet {n1 n2 op} { upvar #0 $options(-textvariable) date # ignore non-changes if {$date eq $formattedDate} return # pass into the system $self set $date return } method CallCommand {} { if {![llength $options(-command)]} return uplevel \#0 $options(-command) [list $formattedDate] $rawDate } method UpdateEntry {} { $hull configure -state normal $hull delete 0 end $hull insert end $formattedDate $hull configure -state readonly return } } # Bindings for menu portion. # # This is a variant of the ttk menubutton.tcl bindings. # See menubutton.tcl for detailed behavior info. # bind TDateEntry { %W state active } bind TDateEntry { %W state !active } bind TDateEntry <> { %W post } bind TDateEntry { %W post } bind TDateEntry { %W unpost } bind TDateEntry { %W state pressed ; %W post } bind TDateEntry { %W state !pressed } # These are to get around issues on aqua (see ttk::combobox bindings) bind TDateEntryPopdown { ttk::globalGrab %W } bind TDateEntryPopdown { ttk::releaseGrab %W } package provide widget::dateentry 0.98 ############## # TEST CODE ## ############## # PhG: this does not work in R #if { [info script] eq $argv0 } { # set auto_path [linsert $auto_path 0 [file dirname [info script]]] # package require widget::dateentry # destroy {*}[winfo children .] # proc getDate { args } { # puts [info level 0] # puts "DATE $::DATE" # update idle # } # # # Samples # # package require widget::dateentry # set ::DATE "" # set start [widget::dateentry .s -textvariable ::DATE \ # -dateformat "%d.%m.%Y %H:%M" \ # -command [list getDate .s]] # set end [widget::dateentry .e \ # -command [list getDate .e] \ # -highlightcolor dimgrey \ # -font {Courier 10} \ # -firstday sunday] # grid [label .sl -text "Start:"] $start -padx 4 -pady 4 # grid [label .el -text "End:" ] $end -padx 4 -pady 4 # # puts [$end get] #} tcltk2/inst/tklibs/widget3.2/dialog.tcl0000644000176200001440000003346315017041713017403 0ustar liggesusers# -*- tcl -*- # # dialog.tcl - # # Generic dialog widget (themed) # # Creation and Options - widget::dialog $path ... # -command -default {} ; # gets appended: $win $reason # -focus -default {} ; # subwindow to set focus on display # -modal -default none # -padding -default 0 # -parent -default "" # -place -default center # -separator -default 1 # -synchronous -default 1 # -title -default "" # -transient -default 1 # -type -default custom ; # {ok okcancel okcancelapply custom} # -timeout -default 0 ; # only active with -synchronous # # Methods # $path add $what $args... => $id # $path getframe => $frame # $path setwidget $widget => "" # $path display # $path cancel # $path withdraw # # Bindings # Escape => invokes [$dlg close cancel] # WM_DELETE_WINDOW => invokes [$dlg close cancel] # if 0 { # Samples package require widget::dialog set dlg [widget::dialog .pkgerr -modal local -separator 1 \ -place right -parent . -type okcancel \ -title "Dialog Title"] set frame [frame $dlg.f] label $frame.lbl -text "Type Something In:" entry $frame.ent grid $frame.lbl $frame.ent -sticky ew grid columnconfigure $frame 1 -weight 1 $dlg setwidget $frame puts [$dlg display] destroy $dlg # Using -synchronous with a -type custom dialog requires that the # custom buttons call [$dlg close $reason] to trigger the close set dlg [widget::dialog .pkgerr -title "Yes/No Dialog" -separator 1 \ -parent . -type custom] set frame [frame $dlg.f] label $frame.lbl -text "Type Something In:" entry $frame.ent grid $frame.lbl $frame.ent -sticky ew grid columnconfigure $frame 1 -weight 1 $dlg setwidget $frame $dlg add button -text "Yes" -command [list $dlg close yes] $dlg add button -text "No" -command [list $dlg close no] puts [$dlg display] } # ### ######### ########################### ## Prerequisites #package require image ; # bitmaps package require snit ; # object system package require msgcat # ### ######### ########################### ## Implementation snit::widget widget::dialog { # ### ######### ########################### hulltype toplevel component frame component separator component buttonbox delegate option -padding to frame; delegate option * to hull delegate method * to hull option -command -default {}; # {none local global} option -modal -default none -configuremethod C-modal; #option -padding -default 0 -configuremethod C-padding; option -parent -default "" -configuremethod C-parent; # {none center left right above below over} option -place -default center -configuremethod C-place; option -separator -default 1 -configuremethod C-separator; option -synchronous -default 1; option -title -default "" -configuremethod C-title; option -transient -default 1 -configuremethod C-transient; option -type -default custom -configuremethod C-type; option -timeout -default 0; option -focus -default ""; # We may make this an easier customizable messagebox, but not yet #option -anchor c; # {n e w s c} #option -text ""; #option -bitmap ""; #option -image ""; # ### ######### ########################### ## Public API. Construction constructor {args} { wm withdraw $win install frame using ttk::frame $win._frame install separator using ttk::separator $win._separator \ -orient horizontal if {[tk windowingsystem] eq "aqua"} { # left top right bottom - Aqua corner resize control padding set btnpad [list 0 6 14 4] } else { # left top right bottom set btnpad [list 0 6 0 4] } install buttonbox using ttk::frame $win._buttonbox -padding $btnpad grid $frame -row 0 -column 0 -sticky news grid $separator -row 1 -column 0 -sticky ew # Should padding effect the buttonbox? grid $buttonbox -row 2 -column 0 -sticky ew grid columnconfigure $win 0 -weight 1 grid rowconfigure $win 0 -weight 1 # Default to invoking no/cancel/withdraw wm protocol $win WM_DELETE_WINDOW [mymethod close cancel] bind $win [mymethod close cancel] # Ensure grab release on unmap? #bind $win [list grab release $win] # Handle defaults if {!$options(-separator)} { grid remove $separator } $self configurelist $args } # ### ######### ########################### ## Public API. Extend container by application specific content. # getframe and setwidget are somewhat mutually exlusive. # Use one or the other. method getframe {} { return $frame } method setwidget {w} { if {[winfo exists $setwidget]} { grid remove $setwidget set setwidget {} } if {[winfo exists $w]} { grid $w -in $frame -row 0 -column 0 -sticky news grid columnconfigure $frame 0 -weight 1 grid rowconfigure $frame 0 -weight 1 set setwidget $w } } variable uid 0 method add {what args} { if {$what eq "button"} { set w [eval [linsert $args 0 ttk::button $buttonbox._b[incr uid]]] } elseif {[winfo exists $what]} { set w $what } else { return -code error "unknown add type \"$what\", must be:\ button or a pathname" } set col [lindex [grid size $buttonbox] 0]; # get last column if {$col == 0} { # ensure weighted 0 column grid columnconfigure $buttonbox 0 -weight 1 incr col } grid $w -row 0 -column $col -sticky ew -padx 4 return $w } method display {} { set lastFocusGrab [focus] set last [grab current $win] lappend lastFocusGrab $last if {[winfo exists $last]} { lappend lastFocusGrab [grab status $last] } $self PlaceWindow $win $options(-place) $options(-parent) if {$options(-modal) ne "none"} { if {$options(-modal) eq "global"} { catch {grab -global $win} } else { catch {grab $win} } } if {[winfo exists $options(-focus)]} { catch { focus $options(-focus) } } # In order to allow !custom synchronous, we need to allow # custom dialogs to set [myvar result]. They do that through # [$dlg close $reason] if {$options(-synchronous)} { if {$options(-timeout) > 0} { # set var after specified timeout set timeout_id [after $options(-timeout) \ [list set [myvar result] timeout]] } vwait [myvar result] catch {after cancel $timeout_id} # A synchronous dialog will always withdraw, even if a -command # tries to return a break code. return [$self withdraw $result] } } method close {{reason {}}} { set code 0 if {$options(-command) ne ""} { set cmd $options(-command) lappend cmd $win $reason set code [catch {uplevel \#0 $cmd} result] } else { # set result to trigger any possible vwait set result $reason } if {$code == 3} { # 'break' return code - don't withdraw return $result } else { # Withdraw on anything but 'break' return code $self withdraw $result } return -code $code $result } method withdraw {{reason "withdraw"}} { set result $reason catch {grab release $win} # Let's avoid focus/grab restore if we don't think we were showing if {![winfo ismapped $win]} { return $reason } wm withdraw $win foreach {oldFocus oldGrab oldStatus} $lastFocusGrab { break } # Ensure last focus/grab wasn't a child of this window if {[winfo exists $oldFocus] && ![string match $win* $oldFocus]} { catch {focus $oldFocus} } if {[winfo exists $oldGrab] && ![string match $win* $oldGrab]} { if {$oldStatus eq "global"} { catch {grab -global $oldGrab} } elseif {$oldStatus eq "local"} { catch {grab $oldGrab} } } return $result } # ### ######### ########################### ## Internal. State variable for close-button (X) variable lastFocusGrab {}; variable isPlaced 0; variable result {}; variable setwidget {}; # ### ######### ########################### ## Internal. Handle changes to the options. method C-title {option value} { wm title $win $value wm iconname $win $value set options($option) $value } method C-modal {option value} { set values [list none local global] if {[lsearch -exact $values $value] == -1} { return -code error "unknown $option option \"$value\":\ must be one of [join $values {, }]" } set options($option) $value } method C-separator {option value} { if {$value} { grid $separator } else { grid remove $separator } set options($option) $value } method C-parent {option value} { if {$options(-transient) && [winfo exists $value]} { wm transient $win [winfo toplevel $value] wm group $win [winfo toplevel $value] } else { wm transient $win "" wm group $win "" } set options($option) $value } method C-transient {option value} { if {$value && [winfo exists $options(-parent)]} { wm transient $win [winfo toplevel $options(-parent)] wm group $win [winfo toplevel $options(-parent)] } else { wm transient $win "" wm group $win "" } set options($option) $value } method C-place {option value} { set values [list none center left right over above below pointer] if {[lsearch -exact $values $value] == -1} { return -code error "unknown $option option \"$value\":\ must be one of [join $values {, }]" } set isPlaced 0 set options($option) $value } method C-type {option value} { set types [list ok okcancel okcancelapply custom] # ok # okcancel # okcancelapply # custom # msgcat if {$options(-type) eq $value} { return } if {[lsearch -exact $types $value] == -1} { return -code error "invalid type \"$value\", must be one of:\ [join $types {, }]" } if {$options(-type) ne "custom"} { # Just trash whatever we had eval [list destroy] [winfo children $buttonbox] } set ok [msgcat::mc "OK"] set cancel [msgcat::mc "Cancel"] set apply [msgcat::mc "Apply"] set okBtn [ttk::button $buttonbox.ok -text $ok -default active \ -command [mymethod close ok]] set canBtn [ttk::button $buttonbox.cancel -text $cancel \ -command [mymethod close cancel]] set appBtn [ttk::button $buttonbox.apply -text $apply \ -command [mymethod close apply]] # [OK] [Cancel] [Apply] grid x $okBtn $canBtn $appBtn -padx 4 grid columnconfigure $buttonbox 0 -weight 1 #bind $win [list $okBtn invoke] #bind $win [list $canBtn invoke] if {$value eq "ok"} { grid remove $canBtn $appBtn } elseif {$value eq "okcancel"} { grid remove $appBtn } set options($option) $value } # ### ######### ########################### ## Internal. method PlaceWindow {w place anchor} { # Variation of tk::PlaceWindow if {$isPlaced || $place eq "none"} { # For most options, we place once and then just deiconify wm deiconify $w raise $w return } set isPlaced 1 if {$place eq "pointer"} { # pointer placement occurs each time, centered set anchor center set isPlaced 0 } elseif {![winfo exists $anchor]} { set anchor [winfo toplevel [winfo parent $w]] if {![winfo ismapped $anchor]} { set place center } } wm withdraw $w update idletasks set checkBounds 1 if {$place eq "center"} { set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}] set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}] set checkBounds 0 } elseif {$place eq "pointer"} { ## place at POINTER (centered) if {$anchor eq "center"} { set x [expr {[winfo pointerx $w]-[winfo reqwidth $w]/2}] set y [expr {[winfo pointery $w]-[winfo reqheight $w]/2}] } else { set x [winfo pointerx $w] set y [winfo pointery $w] } } elseif {![winfo ismapped $anchor]} { ## All the rest require the anchor to be mapped ## If the anchor isn't mapped, use center set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}] set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}] set checkBounds 0 } elseif {$place eq "over"} { ## center about WIDGET $anchor set x [expr {[winfo rootx $anchor] + \ ([winfo width $anchor]-[winfo reqwidth $w])/2}] set y [expr {[winfo rooty $anchor] + \ ([winfo height $anchor]-[winfo reqheight $w])/2}] } elseif {$place eq "above"} { ## above (north of) WIDGET $anchor, centered set x [expr {[winfo rootx $anchor] + \ ([winfo width $anchor]-[winfo reqwidth $w])/2}] set y [expr {[winfo rooty $anchor] - [winfo reqheight $w]}] } elseif {$place eq "below"} { ## below WIDGET $anchor, centered set x [expr {[winfo rootx $anchor] + \ ([winfo width $anchor]-[winfo reqwidth $w])/2}] set y [expr {[winfo rooty $anchor] + [winfo height $anchor]}] } elseif {$place eq "left"} { ## left of WIDGET $anchor, top-aligned set x [expr {[winfo rootx $anchor] - [winfo reqwidth $w]}] set y [winfo rooty $anchor] } elseif {$place eq "right"} { ## right of WIDGET $anchor, top-aligned set x [expr {[winfo rootx $anchor] + [winfo width $anchor]}] set y [winfo rooty $anchor] } else { return -code error "unknown place type \"$place\"" } if {[tk windowingsystem] eq "win32"} { # win32 multiple desktops may produce negative geometry - avoid. set checkBounds -1 } if {$checkBounds} { if {$x < 0 && $checkBounds > 0} { set x 0 } elseif {$x > ([winfo screenwidth $w]-[winfo reqwidth $w])} { set x [expr {[winfo screenwidth $w]-[winfo reqwidth $w]}] } if {$y < 0 && $checkBounds > 0} { set y 0 } elseif {$y > ([winfo screenheight $w]-[winfo reqheight $w])} { set y [expr {[winfo screenheight $w]-[winfo reqheight $w]}] } if {[tk windowingsystem] eq "aqua"} { # Avoid the native menu bar which sits on top of everything. if {$y < 20} { set y 20 } } } wm geometry $w +$x+$y wm deiconify $w raise $w } # ### ######### ########################### } # ### ######### ########################### ## Ready for use package provide widget::dialog 1.3.1 tcltk2/inst/tklibs/widget3.2/widget_calendar.man0000644000176200001440000000565715017041713021255 0ustar liggesusers[comment {-*- tcl -*- doctools manpage}] [vset VERSION 1.0.2] [manpage_begin widget_calendar n [vset VERSION]] [keywords calendar] [keywords date] [keywords megawidget] [keywords snit] [keywords widget] [moddesc {Various megawidgets}] [titledesc {Calendar Megawidget}] [category Widget] [require Tcl 8.4] [require Tk 8.4] [require widget [opt 3.0]] [require widget::calendar [opt [vset VERSION]]] [description] This package provides a calendar megawidget (snidget). [para] [list_begin definitions] [call [cmd widget::calendar] [arg pathname] [opt options]] [list_end] [section "WIDGET OPTIONS"] [para] [list_begin options] [opt_def -command] A script to evaluate when a date was selected. [opt_def -dateformat] The format of the date that is returned. Default: %m/%d/%Y. [opt_def -firstday] Set first day the week, Either sunday or monday. It defaults to monday. [opt_def -font] Select the font used in the widget. It defaults to Helvetica 9. [opt_def -highlightcolor] Selects the background color for the day that has been selected. Default: #FFCC00 [opt_def -language] Specify language of the calendar contents. The language is specified by abbreviations of the languge, for example: en - english, de - german ... It defaults to en. [para] Supported languages: de en es fr gr he it ja sv pl pt zh fi tr nl ru crk crx-nak crx-lhe [opt_def -shadecolor] Selects the color of the parts that have a shaded background. Default: #888888 [opt_def -showpast] Specify if the past shall be shown. It is a boolean value and defaults to 1. [opt_def -textvariable] Specifies the name of a variable whose value is linked to the entry widget's contents. Whenever the variable changes value, the widget's contents are updated, and vice versa. [list_end] [section "WIDGET COMMAND"] [arg pathname] [cmd get] [opt [arg what]] [para] Returns a part of the selected date or 'all'. The argument [arg what] selects the part. Valid values for [arg what] are: day, month, year and all. 'all' is the default and returns the complete date in the format given with -dateformat. [section "DEFAULT BINDINGS"] On creation of the calendar widget the following bindings are installed. When pressing a key the command is invoked and the textvariable is updated. updated. [list_begin itemized] [item] Home - Move to the current date [item] Up - Move to week before current date [item] Down - Move to week after current date [item] Left - Move to day before current date [item] Right - Move to day after current date [item] Control-Left - Move to month before current date [item] Control-Right - Move to month after current date [item] Control-Up - Move to year before current date [item] Control-Down - Move to year after current date [list_end] [section EXAMPLE] [example { package require widget::calendar ; # or widget::all set t [widget::calendar .t] pack $t -fill x -expand 1 }] [vset CATEGORY widget::calendar] [include ../../support/devel/doc/feedback.inc] [manpage_end] tcltk2/inst/tklibs/widget3.2/stext.tcl0000644000176200001440000000405515017041713017306 0ustar liggesusers# -*- tcl -*- # # stext.tcl - # # Scrolled text widget. A blend of the text widget with the # scrolledwindow. # # While I do not recommend making scrolledXXX versions of widgets # (instead, use the 3 line wrapper), this is an example of how one # would do that. # # RCS: @(#) $Id: stext.tcl,v 1.2 2008/12/11 18:07:20 hobbs Exp $ # if 0 { # Samples package require widget::scrolledwindow #set sw [widget::scrolledwindow .sw -scrollbar vertical] #set text [text .sw.text -wrap word] #$sw setwidget $text #pack $sw -fill both -expand 1 proc test {{root .f}} { destroy $root set f [ttk::frame $root] set lbl [ttk::label $f.lbl -text "Scrolled Text snidget:" -anchor w] set st [widget::scrolledtext $f.sw -borderwidth 1 -relief sunken] pack $lbl -fill x pack $st -fill both -expand 1 pack $f -fill both -expand 1 -padx 4 -pady 4 } } ### package require widget package require widget::scrolledwindow snit::widgetadaptor widget::scrolledtext { # based on widget::scrolledwindow component text delegate option * to text delegate method * to text delegate option -scrollbar to hull delegate option -auto to hull delegate option -sides to hull delegate option -borderwidth to hull delegate option -relief to hull constructor args { # You want the outer scrolledwindow to display bd/relief installhull using widget::scrolledwindow install text using text $win.text \ -borderwidth 0 -relief flat -highlightthickness 1 $hull setwidget $text # Enable with the bits below to have a fancy override for text # widget commands (like insert/delete) #rename $text ${selfns}::$text. #interp alias {} $text {} {*}[mymethod _text] # Use Ttk TraverseIn event to handle megawidget focus properly bind $win <> [list focus -force $text] $self configurelist $args } #destructor { rename $text {} } #method _text {cmd args} { # # Here you could override insert or delete ... # uplevel 1 [linsert $args 0 ${selfns}::$text. $cmd] #} } package provide widget::scrolledtext 1.0 tcltk2/inst/tklibs/swaplist0.2/0000755000176200001440000000000015017102465016011 5ustar liggesuserstcltk2/inst/tklibs/swaplist0.2/swaplist.man0000644000176200001440000000537615017041713020365 0ustar liggesusers[comment {-*- tcl -*- doctools manpage}] [manpage_begin swaplist n 0.1] [keywords dialog] [keywords disjointlistbox] [keywords listbox] [moddesc {A dialog which allows a user to move options between two lists}] [titledesc {A dialog which allows a user to move options between two lists}] [category Widget] [require Tcl 8.4] [require Tk 8.4] [require swaplist [opt 0.1]] [description] This package provides a dialog which consists of 2 listboxes, along with buttons to move items between them and reorder the right list. [para] [list_begin definitions] [call [cmd ::swaplist::swaplist] [arg pathName] [arg variable] [arg completeList] [arg selectedList] [opt options]] Creates a dialog which presents the user with a pair of listboxes. Items are selected by using the buttons to move them to the right list. The contents of the right list are put in the [arg variable] upon closure of the dialog. The command returns a boolean indicating if the user pressed OK or not. If -geometry is not specified, the dialog is centered in its parent toplevel unless its parent is . in which case the dialog is centered in the screen. [para] Options: [comment { The list below is the simplest for describing options. A more complex is to use 'tkoption' instead of 'opt', and 'tkoption_def' instead of 'opt_def'. I (AK) refrained from doing so as I do not know the names and classes used for the options in the option database. }] [list_begin options] [opt_def -embed] if this flag is supplied, the procedure will create a swaplist widget named [arg pathName], with the [arg variable] set as the listvariable for the right side listbox. This flag will also cause the -title and -geometry flags to be ignored. [opt_def -reorder] boolean specifying if buttons allowing the user to change the order of the right listbox should appear or not. defaults to true [opt_def -title] sets the title of the dialog window. defaults to "Configuration" [opt_def -llabel] sets the heading above the left list. defaults to "Available:" [opt_def -rlabel] sets the heading above the right list. defaults to "Selected:" [opt_def -lbuttontext] sets the text on the "move left" button. defaults to "<<" [opt_def -rbuttontext] sets the text on the "move right" button. defaults to ">>" [opt_def -ubuttontext] sets the text on the "move up" button. defaults to "Move Up" [opt_def -dbuttontext] sets the text on the "move down" button. defaults to "Move Down" [opt_def -geometry] sets the geometry of the dialog window. [list_end] [list_end] [section EXAMPLE] [example { package require swaplist namespace import swaplist::* if {[swaplist .slist opts "1 2 3 4 5 6 7 8 9" "1 3 5"]} { puts "user chose numbers: $opts" } }] [vset CATEGORY swaplist] [include ../../support/devel/doc/feedback.inc] [manpage_end] tcltk2/inst/tklibs/swaplist0.2/swaplist.tcl0000755000176200001440000003202515017041713020366 0ustar liggesusers# swaplist.tcl -- # # A dialog which allows a user to move options between two lists # # Copyright (c) 2005 Aaron Faupell # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: swaplist.tcl,v 1.6 2008/02/06 07:15:16 afaupell Exp $ package require Tk package provide swaplist 0.2 namespace eval swaplist { namespace export swaplist } if {[tk windowingsystem] == "win32"} { option add *Swaplist*Button.width -10 widgetDefault option add *Swaplist*Button.padX 1m widgetDefault option add *Swaplist*Border.borderWidth 2 widgetDefault option add *Swaplist*Border*Listbox.borderWidth 0 widgetDefault } else { option add *Swaplist.borderWidth 1 widgetDefault option add *Swaplist*Button.width 5 widgetDefault } proc ::swaplist::swaplist {w var list1 list2 args} { array set options { -title "Configuration" } parseOpts options {{-llabel {}} {-rlabel {}} {-title {}} -embed \ {-reorder boolean} {-geometry {}} {-lbuttontext {}} \ {-rbuttontext {}} {-ubuttontext {}} {-dbuttontext {}}} \ $args if {[info exists options(-embed)]} { frame $w unset options(-embed) return [eval [list ::swaplist::createSwaplist $w $var $list1 $list2] [array get options]] } catch {destroy $w} set focus [focus] set grab [grab current .] toplevel $w -class Swaplist -relief raised wm title $w $options(-title) wm protocol $w WM_DELETE_WINDOW {set ::swaplist::whichButton 0} wm transient $w [winfo toplevel [winfo parent $w]] eval [list ::swaplist::createSwaplist $w ::swaplist::selectedList $list1 $list2] [array get options] frame $w.oc -pady 7 button $w.oc.ok -default active -text "OK" -command {set ::swaplist::whichButton 1} button $w.oc.cancel -text "Cancel" -command {set ::swaplist::whichButton 0} pack $w.oc.cancel -side right -padx 7 pack $w.oc.ok -side right grid $w.oc -columnspan 4 -row 2 -column 0 -sticky ew -columnspan 4 bind $w [list $w.oc.ok invoke] bind $w [list $w.oc.cancel invoke] bind $w {set ::swaplist::whichButton 0} #SetButtonState $w wm withdraw $w update idletasks if {[info exists options(-geometry)]} { wm geometry $w $options(-geometry) } elseif {[winfo parent $w] == "."} { set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 - [winfo vrootx $w]}] set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 - [winfo vrooty $w]}] wm geometry $w +$x+$y } else { set t [winfo toplevel [winfo parent $w]] set x [expr {[winfo width $t]/2 - [winfo reqwidth $w]/2 - [winfo vrootx $w]}] set y [expr {[winfo height $t]/2 - [winfo reqheight $w]/2 - [winfo vrooty $w]}] wm geometry $w +$x+$y } wm deiconify $w grab $w tkwait variable ::swaplist::whichButton upvar $var results set results $::swaplist::selectedList bind $w {} grab release $w destroy $w focus -force $focus if {$grab != ""} {grab $grab} update idletasks return $::swaplist::whichButton } proc ::swaplist::createSwaplist {w var list1 list2 args} { array set options { -reorder 1 -llabel "Available:" -rlabel "Selected:" -lbuttontext "<<" -rbuttontext ">>" -ubuttontext "Move Up" -dbuttontext "Move Down" } parseOpts options {{-llabel {}} {-rlabel {}} {-title {}} \ {-reorder boolean} {-lbuttontext {}} {-geometry {}}\ {-rbuttontext {}} {-ubuttontext {}} {-dbuttontext {}}} \ $args set olist $list1 # remove items in list2 from list1 foreach x $list2 { if {[set i [lsearch $list1 $x]] >= 0} { set list1 [lreplace $list1 $i $i] } } label $w.heading1 -text $options(-llabel) -anchor w label $w.heading2 -text $options(-rlabel) -anchor w foreach x {list1 list2} { frame $w.$x -class Border -relief sunken scrollbar $w.$x.scrolly -orient v -command [list $w.$x.list yview] scrollbar $w.$x.scrollx -orient h -command [list $w.$x.list xview] listbox $w.$x.list -selectmode extended -yscrollcommand [list $w.$x.scrolly set] -xscrollcommand [list $w.$x.scrollx set] grid $w.$x.list -row 0 -column 0 -sticky nesw grid $w.$x.scrolly -row 0 -column 1 -sticky ns grid $w.$x.scrollx -row 1 -column 0 -sticky ew grid columnconfigure $w.$x 0 -weight 1 grid rowconfigure $w.$x 0 -weight 1 } $w.list2.list configure -listvariable $var $w.list2.list delete 0 end eval [list $w.list1.list insert end] $list1 eval [list $w.list2.list insert end] $list2 set width [min 5 $options(-lbuttontext) $options(-rbuttontext)] frame $w.lr button $w.lr.left -width $width -text $options(-lbuttontext) -command [list ::swaplist::ShiftL $w $olist] if {$options(-reorder)} { button $w.lr.right -width $width -text $options(-rbuttontext) -command [list ::swaplist::ShiftRNormal $w $olist] } else { button $w.lr.right -width $width -text $options(-rbuttontext) -command [list ::swaplist::ShiftRNoReorder $w $olist] } grid $w.lr.right -pady 4 grid $w.lr.left -pady 4 grid columnconfigure $w.lr 0 -uniform 1 set width [min 3 $options(-ubuttontext) $options(-dbuttontext)] frame $w.ud button $w.ud.up -width $width -text $options(-ubuttontext) -command [list ::swaplist::ShiftUD $w.list2.list u] button $w.ud.down -width $width -text $options(-dbuttontext) -command [list ::swaplist::ShiftUD $w.list2.list d] pack $w.ud.up -side top -pady 4 pack $w.ud.down -side bottom -pady 4 grid $w.heading1 -row 0 -column 0 -sticky ew -padx {3 0} -pady 3 grid $w.heading2 -row 0 -column 2 -sticky ew -padx {0 3} -pady 3 grid $w.list1 -row 1 -column 0 -sticky nesw -padx {3 0} grid $w.lr -row 1 -column 1 -padx 7 grid $w.list2 -row 1 -column 2 -sticky nesw -padx {0 3} if {$options(-reorder)} { grid $w.ud -row 1 -column 3 -padx {2 5} } grid columnconfigure $w {0 2} -weight 1 grid rowconfigure $w 1 -weight 1 bind $w [list ::swaplist::UpDown %W %K] bind $w [list ::swaplist::UpDown %W %K] bind $w.list1.list [list ::swaplist::Double %W] bind $w.list2.list [list ::swaplist::Double %W] #bind $w.list1.list <> [list ::swaplist::SetButtonState %W] #bind $w.list2.list <> [list ::swaplist::SetButtonState %W] if {![catch {package present autoscroll}]} { ::autoscroll::autoscroll $w.list1.scrollx ::autoscroll::autoscroll $w.list1.scrolly ::autoscroll::autoscroll $w.list2.scrollx ::autoscroll::autoscroll $w.list2.scrolly } #SetButtonState $w return $w } proc ::swaplist::parseOpts {var opts input} { upvar $var output for {set i 0} {$i < [llength $input]} {incr i} { for {set a 0} {$a < [llength $opts]} {incr a} { if {[lindex $opts $a 0] == [lindex $input $i]} { break } } if {$a == [llength $opts]} { error "unknown option [lindex $input $i]" } set opt [lindex $opts $a] if {[llength $opt] > 1} { foreach {opt type} $opt {break} if {[incr i] >= [llength $input]} { error "$opt requires an argument" } if {$type != "" && ![string is $type -strict [lindex $input $i]]} { error "$opt requires argument of type $type" } set output($opt) [lindex $input $i] } else { set output($opt) {} } } } # return the min unless string1 or string2 is longer, if so return length of the longer one proc ::swaplist::min {min s1 s2} { if {[string length $s1] > $min || [string length $s2] > $min} { return [expr { ([string length $s1] > [string length $s2]) \ ? [string length $s1] \ : [string length $s2] }] } else { return $min } } # return a list in reversed order proc ::swaplist::lreverse {list} { set new {} foreach x $list {set new [linsert $new 0 $x]} return $new } # binding for "move left" button proc ::swaplist::ShiftL {w olist} { set from $w.list2.list set to $w.list1.list if {[set cur [$from curselection]] == ""} { return } foreach x [lreverse $cur] { set name [$from get $x] $from delete $x set i [FindPos $olist [$to get 0 end] $name] $to insert $i $name $to selection set $i } if {[llength $cur] == 1} {$to see $i} if {[lindex $cur 0] == 0} { $from selection set 0 } elseif {[lindex $cur 0] == [$from index end]} { $from selection set end } else { $from selection set [lindex $cur 0] } } # binding for "move right" button if -reorder is true proc ::swaplist::ShiftRNormal {w olist} { set from $w.list1.list set to $w.list2.list if {[set cur [$from curselection]] == ""} { return } $to selection clear 0 end foreach x $cur { $to insert end [$from get $x] $to selection set end } foreach x [lreverse $cur] { $from delete $x } $to see end } # binding for "move right" button if -reorder is false proc ::swaplist::ShiftRNoReorder {w olist} { set from $w.list1.list set to $w.list2.list if {[set cur [$from curselection]] == ""} { return } foreach x $cur { set name [$from get $x] set pos [FindPos $olist [$to get 0 end] $name] $to insert $pos $name lappend new $pos } foreach x [lreverse $cur] { $from delete $x } if {[$from index end] == 0} { foreach x $new {$to selection set $x} } elseif {[lindex $cur 0] == 0} { $from selection set 0 } elseif {[lindex $cur 0] == [$from index end]} { $from selection set end } else { $from selection set [lindex $cur 0] } } # binding for "move up" and "move down" buttons proc ::swaplist::ShiftUD {w dir} { if {[set sel [$w curselection]] == ""} { return } set list {} # delete in reverse order so shifting indexes dont bite us foreach x [lreverse $sel] { # make a list in correct order with the items index and contents set list [linsert $list 0 [list $x [$w get $x]]] $w delete $x } if {$dir == "u"} { set n 0 foreach x $list { set i [lindex $x 0] if {[incr i -1] < $n} {set i $n} $w insert $i [lindex $x 1] $w selection set $i incr n } $w see [expr {[lindex $list 0 0] - 1}] } if {$dir == "d"} { set n [$w index end] foreach x $list { set i [lindex $x 0] if {[incr i] > $n} {set i $n} $w insert $i [lindex $x 1] $w selection set $i incr n } $w see $i } } # find the position $el should have in $curlist, by looking at $olist # $curlist should be a subset of $olist proc ::swaplist::FindPos {olist curlist el} { set orig [lsearch $olist $el] set end [llength $curlist] for {set i 0} {$i < $end} {incr i} { if {[lsearch $olist [lindex $curlist $i]] > $orig} { break } } return $i } # binding for the up and down arrow keys, just dispatch and have tk # do the right thing proc ::swaplist::UpDown {w key} { if {[winfo toplevel $w] != $w} {return} if {[set cur [$w.list2.list curselection]] != ""} { tk::ListboxUpDown $w.list2.list [string map {Up -1 Down 1} $key] } elseif {[set cur [$w.list1.list curselection]] != ""} { tk::ListboxUpDown $w.list1.list [string map {Up -1 Down 1} $key] } else { return } } # binding for double click, just invoke the left or right button proc ::swaplist::Double {w} { set top [winfo toplevel $w] if {[string match *.list1.* $w]} { $top.lr.right invoke } elseif {[string match *.list2.* $w]} { $top.lr.left invoke } } proc ::swaplist::SetButtonState {w} { set top [winfo toplevel $w] if {[$top.list2.list curselection] != ""} { $top.lr.left configure -state normal $top.lr.right configure -state disabled } elseif {[$top.list1.list curselection] != ""} { $top.lr.left configure -state disabled $top.lr.right configure -state normal } else { $top.lr.left configure -state disabled $top.lr.right configure -state disabled } if {[set cur [$top.list2.list curselection]] == ""} { $top.ud.up configure -state disabled $top.ud.down configure -state disabled } elseif {$cur == 0} { $top.ud.up configure -state disabled $top.ud.down configure -state normal } elseif {$cur == ([$top.list2.list index end] - 1)} { $top.ud.up configure -state normal $top.ud.down configure -state disabled } else { $top.ud.up configure -state normal $top.ud.down configure -state normal } } tcltk2/inst/tklibs/swaplist0.2/pkgIndex.tcl0000644000176200001440000000114015017041713020260 0ustar liggesusers# Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. if { ![package vsatisfies [package provide Tcl] 8.4-] } { return } package ifneeded swaplist 0.2 [list source [file join $dir swaplist.tcl]] tcltk2/inst/tklibs/swaplist0.2/ChangeLog0000644000176200001440000000227015017041713017562 0ustar liggesusers2020-02-09 0.7 * * Released and tagged Tklib 0.7 ======================== * 2013-03-25 Andreas Kupries * * Released and tagged Tklib 0.6 ======================== * 2009-01-21 Andreas Kupries * * Released and tagged Tklib 0.5 ======================== * 2008-02-06 Aaron Faupell * swaplist.tcl: fix for bug when moving last item to the right when -reorder is 0. increment version 2005-11-10 Andreas Kupries * * Released and tagged Tklib 0.4.1 ======================== * 2005-11-02 Andreas Kupries * * Released and tagged Tklib 0.4 ======================== * 2005-08-17 Andreas Kupries * swaplist.man: * swaplist.tcl: Added the missing dependency on Tk. 2005-04-01 Andreas Kupries * swaplist.man: Fixed typo in heading, a reference to 'getstring'. Also made the list of options a true list. 2005-03-31 Aaron Faupell * initial import tcltk2/inst/tklibs/swaplist0.2/example.tcl0000644000176200001440000000025614656355210020161 0ustar liggesusers#package require swaplist source ./swaplist.tcl namespace import swaplist::* if {[swaplist .slist opts "1 2 3 4 5 6 7 8 9" "1 3 5"]} { puts "user chose numbers: $opts" }tcltk2/inst/tklibs/snit2.3.4/0000755000176200001440000000000015017041713015263 5ustar liggesuserstcltk2/inst/tklibs/snit2.3.4/main1.tcl0000644000176200001440000037141515017041713017007 0ustar liggesusers#----------------------------------------------------------------------- # TITLE: # main1.tcl # # AUTHOR: # Will Duquette # # DESCRIPTION: # Snit's Not Incr Tcl, a simple object system in Pure Tcl. # # Snit 1.x Compiler and Run-Time Library, Tcl 8.4 and later # # Copyright (C) 2003-2006 by William H. Duquette # This code is licensed as described in license.txt. # #----------------------------------------------------------------------- #----------------------------------------------------------------------- # Namespace namespace eval ::snit:: { namespace export \ compile type widget widgetadaptor typemethod method macro } #----------------------------------------------------------------------- # Some Snit variables namespace eval ::snit:: { variable reservedArgs {type selfns win self} # Widget classes which can be hulls (must have -class) variable hulltypes { toplevel tk::toplevel frame tk::frame ttk::frame labelframe tk::labelframe ttk::labelframe } } #----------------------------------------------------------------------- # Snit Type Implementation template namespace eval ::snit:: { # Template type definition: All internal and user-visible Snit # implementation code. # # The following placeholders will automatically be replaced with # the client's code, in two passes: # # First pass: # %COMPILEDDEFS% The compiled type definition. # # Second pass: # %TYPE% The fully qualified type name. # %IVARDECS% Instance variable declarations # %TVARDECS% Type variable declarations # %TCONSTBODY% Type constructor body # %INSTANCEVARS% The compiled instance variable initialization code. # %TYPEVARS% The compiled type variable initialization code. # This is the overall type template. variable typeTemplate # This is the normal type proc variable nominalTypeProc # This is the "-hastypemethods no" type proc variable simpleTypeProc } set ::snit::typeTemplate { #------------------------------------------------------------------- # The type's namespace definition and the user's type variables namespace eval %TYPE% {%TYPEVARS% } #---------------------------------------------------------------- # Commands for use in methods, typemethods, etc. # # These are implemented as aliases into the Snit runtime library. interp alias {} %TYPE%::installhull {} ::snit::RT.installhull %TYPE% interp alias {} %TYPE%::install {} ::snit::RT.install %TYPE% interp alias {} %TYPE%::typevariable {} ::variable interp alias {} %TYPE%::variable {} ::snit::RT.variable interp alias {} %TYPE%::mytypevar {} ::snit::RT.mytypevar %TYPE% interp alias {} %TYPE%::typevarname {} ::snit::RT.mytypevar %TYPE% interp alias {} %TYPE%::myvar {} ::snit::RT.myvar interp alias {} %TYPE%::varname {} ::snit::RT.myvar interp alias {} %TYPE%::codename {} ::snit::RT.codename %TYPE% interp alias {} %TYPE%::myproc {} ::snit::RT.myproc %TYPE% interp alias {} %TYPE%::mymethod {} ::snit::RT.mymethod interp alias {} %TYPE%::mytypemethod {} ::snit::RT.mytypemethod %TYPE% interp alias {} %TYPE%::from {} ::snit::RT.from %TYPE% #------------------------------------------------------------------- # Snit's internal variables namespace eval %TYPE% { # Array: General Snit Info # # ns: The type's namespace # hasinstances: T or F, from pragma -hasinstances. # simpledispatch: T or F, from pragma -hasinstances. # canreplace: T or F, from pragma -canreplace. # counter: Count of instances created so far. # widgetclass: Set by widgetclass statement. # hulltype: Hull type (frame or toplevel) for widgets only. # exceptmethods: Methods explicitly not delegated to * # excepttypemethods: Methods explicitly not delegated to * # tvardecs: Type variable declarations--for dynamic methods # ivardecs: Instance variable declarations--for dyn. methods typevariable Snit_info set Snit_info(ns) %TYPE%:: set Snit_info(hasinstances) 1 set Snit_info(simpledispatch) 0 set Snit_info(canreplace) 0 set Snit_info(counter) 0 set Snit_info(widgetclass) {} set Snit_info(hulltype) frame set Snit_info(exceptmethods) {} set Snit_info(excepttypemethods) {} set Snit_info(tvardecs) {%TVARDECS%} set Snit_info(ivardecs) {%IVARDECS%} # Array: Public methods of this type. # The index is the method name, or "*". # The value is [list $pattern $componentName], where # $componentName is "" for normal methods. typevariable Snit_typemethodInfo array unset Snit_typemethodInfo # Array: Public methods of instances of this type. # The index is the method name, or "*". # The value is [list $pattern $componentName], where # $componentName is "" for normal methods. typevariable Snit_methodInfo array unset Snit_methodInfo # Array: option information. See dictionary.txt. typevariable Snit_optionInfo array unset Snit_optionInfo set Snit_optionInfo(local) {} set Snit_optionInfo(delegated) {} set Snit_optionInfo(starcomp) {} set Snit_optionInfo(except) {} } #---------------------------------------------------------------- # Compiled Procs # # These commands are created or replaced during compilation: # Snit_instanceVars selfns # # Initializes the instance variables, if any. Called during # instance creation. proc %TYPE%::Snit_instanceVars {selfns} { %INSTANCEVARS% } # Type Constructor proc %TYPE%::Snit_typeconstructor {type} { %TVARDECS% %TCONSTBODY% } #---------------------------------------------------------------- # Default Procs # # These commands might be replaced during compilation: # Snit_destructor type selfns win self # # Default destructor for the type. By default, it does # nothing. It's replaced by any user destructor. # For types, it's called by method destroy; for widgettypes, # it's called by a destroy event handler. proc %TYPE%::Snit_destructor {type selfns win self} { } #---------------------------------------------------------- # Compiled Definitions %COMPILEDDEFS% #---------------------------------------------------------- # Finally, call the Type Constructor %TYPE%::Snit_typeconstructor %TYPE% } #----------------------------------------------------------------------- # Type procs # # These procs expect the fully-qualified type name to be # substituted in for %TYPE%. # This is the nominal type proc. It supports typemethods and # delegated typemethods. set ::snit::nominalTypeProc { # Type dispatcher function. Note: This function lives # in the parent of the %TYPE% namespace! All accesses to # %TYPE% variables and methods must be qualified! proc %TYPE% {{method ""} args} { # First, if there's no method, and no args, and there's a create # method, and this isn't a widget, then method is "create" and # "args" is %AUTO%. if {"" == $method && [llength $args] == 0} { ::variable %TYPE%::Snit_info if {$Snit_info(hasinstances) && !$Snit_info(isWidget)} { set method create lappend args %AUTO% } else { error "wrong \# args: should be \"%TYPE% method args\"" } } # Next, retrieve the command. variable %TYPE%::Snit_typemethodCache while 1 { if {[catch {set Snit_typemethodCache($method)} commandRec]} { set commandRec [::snit::RT.CacheTypemethodCommand %TYPE% $method] if {[llength $commandRec] == 0} { return -code error "\"%TYPE% $method\" is not defined" } } # If we've got a real command, break. if {[lindex $commandRec 0] == 0} { break } # Otherwise, we need to look up again...if we can. if {[llength $args] == 0} { return -code error \ "wrong number args: should be \"%TYPE% $method method args\"" } lappend method [lindex $args 0] set args [lrange $args 1 end] } set command [lindex $commandRec 1] # Pass along the return code unchanged. set retval [catch {uplevel 1 $command $args} result] if {$retval} { if {$retval == 1} { global errorInfo global errorCode return -code error -errorinfo $errorInfo \ -errorcode $errorCode $result } else { return -code $retval $result } } return $result } } # This is the simplified type proc for when there are no typemethods # except create. In this case, it doesn't take a method argument; # the method is always "create". set ::snit::simpleTypeProc { # Type dispatcher function. Note: This function lives # in the parent of the %TYPE% namespace! All accesses to # %TYPE% variables and methods must be qualified! proc %TYPE% {args} { ::variable %TYPE%::Snit_info # FIRST, if the are no args, the single arg is %AUTO% if {[llength $args] == 0} { if {$Snit_info(isWidget)} { error "wrong \# args: should be \"%TYPE% name args\"" } lappend args %AUTO% } # NEXT, we're going to call the create method. # Pass along the return code unchanged. if {$Snit_info(isWidget)} { set command [list ::snit::RT.widget.typemethod.create %TYPE%] } else { set command [list ::snit::RT.type.typemethod.create %TYPE%] } set retval [catch {uplevel 1 $command $args} result] if {$retval} { if {$retval == 1} { global errorInfo global errorCode return -code error -errorinfo $errorInfo \ -errorcode $errorCode $result } else { return -code $retval $result } } return $result } } #----------------------------------------------------------------------- # Instance procs # # The following must be substituted into these proc bodies: # # %SELFNS% The instance namespace # %WIN% The original instance name # %TYPE% The fully-qualified type name # # Nominal instance proc body: supports method caching and delegation. # # proc $instanceName {method args} .... set ::snit::nominalInstanceProc { set self [set %SELFNS%::Snit_instance] while {1} { if {[catch {set %SELFNS%::Snit_methodCache($method)} commandRec]} { set commandRec [snit::RT.CacheMethodCommand %TYPE% %SELFNS% %WIN% $self $method] if {[llength $commandRec] == 0} { return -code error \ "\"$self $method\" is not defined" } } # If we've got a real command, break. if {[lindex $commandRec 0] == 0} { break } # Otherwise, we need to look up again...if we can. if {[llength $args] == 0} { return -code error \ "wrong number args: should be \"$self $method method args\"" } lappend method [lindex $args 0] set args [lrange $args 1 end] } set command [lindex $commandRec 1] # Pass along the return code unchanged. set retval [catch {uplevel 1 $command $args} result] if {$retval} { if {$retval == 1} { global errorInfo global errorCode return -code error -errorinfo $errorInfo \ -errorcode $errorCode $result } else { return -code $retval $result } } return $result } # Simplified method proc body: No delegation allowed; no support for # upvar or exotic return codes or hierarchical methods. Designed for # max speed for simple types. # # proc $instanceName {method args} .... set ::snit::simpleInstanceProc { set self [set %SELFNS%::Snit_instance] if {[lsearch -exact ${%TYPE%::Snit_methods} $method] == -1} { set optlist [join ${%TYPE%::Snit_methods} ", "] set optlist [linsert $optlist "end-1" "or"] error "bad option \"$method\": must be $optlist" } eval [linsert $args 0 \ %TYPE%::Snit_method$method %TYPE% %SELFNS% %WIN% $self] } #======================================================================= # Snit Type Definition # # These are the procs used to define Snit types, widgets, and # widgetadaptors. #----------------------------------------------------------------------- # Snit Compilation Variables # # The following variables are used while Snit is compiling a type, # and are disposed afterwards. namespace eval ::snit:: { # The compiler variable contains the name of the slave interpreter # used to compile type definitions. variable compiler "" # The compile array accumulates information about the type or # widgettype being compiled. It is cleared before and after each # compilation. It has these indices: # # type: The name of the type being compiled, for use # in compilation procs. # defs: Compiled definitions, both standard and client. # which: type, widget, widgetadaptor # instancevars: Instance variable definitions and initializations. # ivprocdec: Instance variable proc declarations. # tvprocdec: Type variable proc declarations. # typeconstructor: Type constructor body. # widgetclass: The widgetclass, for snit::widgets, only # hasoptions: False, initially; set to true when first # option is defined. # localoptions: Names of local options. # delegatedoptions: Names of delegated options. # localmethods: Names of locally defined methods. # delegatesmethods: no if no delegated methods, yes otherwise. # hashierarchic : no if no hierarchic methods, yes otherwise. # components: Names of defined components. # typecomponents: Names of defined typecomponents. # typevars: Typevariable definitions and initializations. # varnames: Names of instance variables # typevarnames Names of type variables # hasconstructor False, initially; true when constructor is # defined. # resource-$opt The option's resource name # class-$opt The option's class # -default-$opt The option's default value # -validatemethod-$opt The option's validate method # -configuremethod-$opt The option's configure method # -cgetmethod-$opt The option's cget method. # -hastypeinfo The -hastypeinfo pragma # -hastypedestroy The -hastypedestroy pragma # -hastypemethods The -hastypemethods pragma # -hasinfo The -hasinfo pragma # -hasinstances The -hasinstances pragma # -simpledispatch The -simpledispatch pragma # -canreplace The -canreplace pragma variable compile # This variable accumulates method dispatch information; it has # the same structure as the %TYPE%::Snit_methodInfo array, and is # used to initialize it. variable methodInfo # This variable accumulates typemethod dispatch information; it has # the same structure as the %TYPE%::Snit_typemethodInfo array, and is # used to initialize it. variable typemethodInfo # The following variable lists the reserved type definition statement # names, e.g., the names you can't use as macros. It's built at # compiler definition time using "info commands". variable reservedwords {} } #----------------------------------------------------------------------- # type compilation commands # # The type and widgettype commands use a slave interpreter to compile # the type definition. These are the procs # that are aliased into it. # Initialize the compiler proc ::snit::Comp.Init {} { variable compiler variable reservedwords if {"" == $compiler} { # Create the compiler's interpreter set compiler [interp create] # Initialize the interpreter $compiler eval { catch {close stdout} catch {close stderr} catch {close stdin} # Load package information # TBD: see if this can be moved outside. # @mdgen NODEP: ::snit::__does_not_exist__ catch {package require ::snit::__does_not_exist__} # Protect some Tcl commands our type definitions # will shadow. rename proc _proc rename variable _variable } # Define compilation aliases. $compiler alias pragma ::snit::Comp.statement.pragma $compiler alias widgetclass ::snit::Comp.statement.widgetclass $compiler alias hulltype ::snit::Comp.statement.hulltype $compiler alias constructor ::snit::Comp.statement.constructor $compiler alias destructor ::snit::Comp.statement.destructor $compiler alias option ::snit::Comp.statement.option $compiler alias oncget ::snit::Comp.statement.oncget $compiler alias onconfigure ::snit::Comp.statement.onconfigure $compiler alias method ::snit::Comp.statement.method $compiler alias typemethod ::snit::Comp.statement.typemethod $compiler alias typeconstructor ::snit::Comp.statement.typeconstructor $compiler alias proc ::snit::Comp.statement.proc $compiler alias typevariable ::snit::Comp.statement.typevariable $compiler alias variable ::snit::Comp.statement.variable $compiler alias typecomponent ::snit::Comp.statement.typecomponent $compiler alias component ::snit::Comp.statement.component $compiler alias delegate ::snit::Comp.statement.delegate $compiler alias expose ::snit::Comp.statement.expose # Get the list of reserved words set reservedwords [$compiler eval {info commands}] } } # Compile a type definition, and return the results as a list of two # items: the fully-qualified type name, and a script that will define # the type when executed. # # which type, widget, or widgetadaptor # type the type name # body the type definition proc ::snit::Comp.Compile {which type body} { variable typeTemplate variable nominalTypeProc variable simpleTypeProc variable compile variable compiler variable methodInfo variable typemethodInfo # FIRST, qualify the name. if {![string match "::*" $type]} { # Get caller's namespace; # append :: if not global namespace. set ns [uplevel 2 [list namespace current]] if {"::" != $ns} { append ns "::" } set type "$ns$type" } # NEXT, create and initialize the compiler, if needed. Comp.Init # NEXT, initialize the class data array unset methodInfo array unset typemethodInfo array unset compile set compile(type) $type set compile(defs) {} set compile(which) $which set compile(hasoptions) no set compile(localoptions) {} set compile(instancevars) {} set compile(typevars) {} set compile(delegatedoptions) {} set compile(ivprocdec) {} set compile(tvprocdec) {} set compile(typeconstructor) {} set compile(widgetclass) {} set compile(hulltype) {} set compile(localmethods) {} set compile(delegatesmethods) no set compile(hashierarchic) no set compile(components) {} set compile(typecomponents) {} set compile(varnames) {} set compile(typevarnames) {} set compile(hasconstructor) no set compile(-hastypedestroy) yes set compile(-hastypeinfo) yes set compile(-hastypemethods) yes set compile(-hasinfo) yes set compile(-hasinstances) yes set compile(-simpledispatch) no set compile(-canreplace) no set isWidget [string match widget* $which] set isWidgetAdaptor [string match widgetadaptor $which] # NEXT, Evaluate the type's definition in the class interpreter. $compiler eval $body # NEXT, Add the standard definitions append compile(defs) \ "\nset %TYPE%::Snit_info(isWidget) $isWidget\n" append compile(defs) \ "\nset %TYPE%::Snit_info(isWidgetAdaptor) $isWidgetAdaptor\n" # Indicate whether the type can create instances that replace # existing commands. append compile(defs) "\nset %TYPE%::Snit_info(canreplace) $compile(-canreplace)\n" # Check pragmas for conflict. if {!$compile(-hastypemethods) && !$compile(-hasinstances)} { error "$which $type has neither typemethods nor instances" } if {$compile(-simpledispatch) && $compile(delegatesmethods)} { error "$which $type requests -simpledispatch but delegates methods." } if {$compile(-simpledispatch) && $compile(hashierarchic)} { error "$which $type requests -simpledispatch but defines hierarchical methods." } # If there are typemethods, define the standard typemethods and # the nominal type proc. Otherwise define the simple type proc. if {$compile(-hastypemethods)} { # Add the info typemethod unless the pragma forbids it. if {$compile(-hastypeinfo)} { Comp.statement.delegate typemethod info \ using {::snit::RT.typemethod.info %t} } # Add the destroy typemethod unless the pragma forbids it. if {$compile(-hastypedestroy)} { Comp.statement.delegate typemethod destroy \ using {::snit::RT.typemethod.destroy %t} } # Add the nominal type proc. append compile(defs) $nominalTypeProc } else { # Add the simple type proc. append compile(defs) $simpleTypeProc } # Add standard methods/typemethods that only make sense if the # type has instances. if {$compile(-hasinstances)} { # If we're using simple dispatch, remember that. if {$compile(-simpledispatch)} { append compile(defs) "\nset %TYPE%::Snit_info(simpledispatch) 1\n" } # Add the info method unless the pragma forbids it. if {$compile(-hasinfo)} { if {!$compile(-simpledispatch)} { Comp.statement.delegate method info \ using {::snit::RT.method.info %t %n %w %s} } else { Comp.statement.method info {args} { eval [linsert $args 0 \ ::snit::RT.method.info $type $selfns $win $self] } } } # Add the option handling stuff if there are any options. if {$compile(hasoptions)} { Comp.statement.variable options if {!$compile(-simpledispatch)} { Comp.statement.delegate method cget \ using {::snit::RT.method.cget %t %n %w %s} Comp.statement.delegate method configurelist \ using {::snit::RT.method.configurelist %t %n %w %s} Comp.statement.delegate method configure \ using {::snit::RT.method.configure %t %n %w %s} } else { Comp.statement.method cget {args} { eval [linsert $args 0 \ ::snit::RT.method.cget $type $selfns $win $self] } Comp.statement.method configurelist {args} { eval [linsert $args 0 \ ::snit::RT.method.configurelist $type $selfns $win $self] } Comp.statement.method configure {args} { eval [linsert $args 0 \ ::snit::RT.method.configure $type $selfns $win $self] } } } # Add a default constructor, if they haven't already defined one. # If there are options, it will configure args; otherwise it # will do nothing. if {!$compile(hasconstructor)} { if {$compile(hasoptions)} { Comp.statement.constructor {args} { $self configurelist $args } } else { Comp.statement.constructor {} {} } } if {!$isWidget} { if {!$compile(-simpledispatch)} { Comp.statement.delegate method destroy \ using {::snit::RT.method.destroy %t %n %w %s} } else { Comp.statement.method destroy {args} { eval [linsert $args 0 \ ::snit::RT.method.destroy $type $selfns $win $self] } } Comp.statement.delegate typemethod create \ using {::snit::RT.type.typemethod.create %t} } else { Comp.statement.delegate typemethod create \ using {::snit::RT.widget.typemethod.create %t} } # Save the list of method names, for -simpledispatch; otherwise, # save the method info. if {$compile(-simpledispatch)} { append compile(defs) \ "\nset %TYPE%::Snit_methods [list $compile(localmethods)]\n" } else { append compile(defs) \ "\narray set %TYPE%::Snit_methodInfo [list [array get methodInfo]]\n" } } else { append compile(defs) "\nset %TYPE%::Snit_info(hasinstances) 0\n" } # NEXT, compiling the type definition built up a set of information # about the type's locally defined options; add this information to # the compiled definition. Comp.SaveOptionInfo # NEXT, compiling the type definition built up a set of information # about the typemethods; save the typemethod info. append compile(defs) \ "\narray set %TYPE%::Snit_typemethodInfo [list [array get typemethodInfo]]\n" # NEXT, if this is a widget define the hull component if it isn't # already defined. if {$isWidget} { Comp.DefineComponent hull } # NEXT, substitute the compiled definition into the type template # to get the type definition script. set defscript [Expand $typeTemplate \ %COMPILEDDEFS% $compile(defs)] # NEXT, substitute the defined macros into the type definition script. # This is done as a separate step so that the compile(defs) can # contain the macros defined below. set defscript [Expand $defscript \ %TYPE% $type \ %IVARDECS% $compile(ivprocdec) \ %TVARDECS% $compile(tvprocdec) \ %TCONSTBODY% $compile(typeconstructor) \ %INSTANCEVARS% $compile(instancevars) \ %TYPEVARS% $compile(typevars) \ ] array unset compile return [list $type $defscript] } # Information about locally-defined options is accumulated during # compilation, but not added to the compiled definition--the option # statement can appear multiple times, so it's easier this way. # This proc fills in Snit_optionInfo with the accumulated information. # # It also computes the option's resource and class names if needed. # # Note that the information for delegated options was put in # Snit_optionInfo during compilation. proc ::snit::Comp.SaveOptionInfo {} { variable compile foreach option $compile(localoptions) { if {"" == $compile(resource-$option)} { set compile(resource-$option) [string range $option 1 end] } if {"" == $compile(class-$option)} { set compile(class-$option) [Capitalize $compile(resource-$option)] } # NOTE: Don't verify that the validate, configure, and cget # values name real methods; the methods might be defined outside # the typedefinition using snit::method. Mappend compile(defs) { # Option %OPTION% lappend %TYPE%::Snit_optionInfo(local) %OPTION% set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 1 set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RESOURCE% set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS% set %TYPE%::Snit_optionInfo(default-%OPTION%) %DEFAULT% set %TYPE%::Snit_optionInfo(validate-%OPTION%) %VALIDATE% set %TYPE%::Snit_optionInfo(configure-%OPTION%) %CONFIGURE% set %TYPE%::Snit_optionInfo(cget-%OPTION%) %CGET% set %TYPE%::Snit_optionInfo(readonly-%OPTION%) %READONLY% set %TYPE%::Snit_optionInfo(typespec-%OPTION%) %TYPESPEC% } %OPTION% $option \ %RESOURCE% $compile(resource-$option) \ %CLASS% $compile(class-$option) \ %DEFAULT% [list $compile(-default-$option)] \ %VALIDATE% [list $compile(-validatemethod-$option)] \ %CONFIGURE% [list $compile(-configuremethod-$option)] \ %CGET% [list $compile(-cgetmethod-$option)] \ %READONLY% $compile(-readonly-$option) \ %TYPESPEC% [list $compile(-type-$option)] } } # Evaluates a compiled type definition, thus making the type available. proc ::snit::Comp.Define {compResult} { # The compilation result is a list containing the fully qualified # type name and a script to evaluate to define the type. set type [lindex $compResult 0] set defscript [lindex $compResult 1] # Execute the type definition script. # Consider using namespace eval %TYPE%. See if it's faster. if {[catch {eval $defscript} result]} { namespace delete $type catch {rename $type ""} error $result } return $type } # Sets pragma options which control how the type is defined. proc ::snit::Comp.statement.pragma {args} { variable compile set errRoot "Error in \"pragma...\"" foreach {opt val} $args { switch -exact -- $opt { -hastypeinfo - -hastypedestroy - -hastypemethods - -hasinstances - -simpledispatch - -hasinfo - -canreplace { if {![string is boolean -strict $val]} { error "$errRoot, \"$opt\" requires a boolean value" } set compile($opt) $val } default { error "$errRoot, unknown pragma" } } } } # Defines a widget's option class name. # This statement is only available for snit::widgets, # not for snit::types or snit::widgetadaptors. proc ::snit::Comp.statement.widgetclass {name} { variable compile # First, widgetclass can only be set for true widgets if {"widget" != $compile(which)} { error "widgetclass cannot be set for snit::$compile(which)s" } # Next, validate the option name. We'll require that it begin # with an uppercase letter. set initial [string index $name 0] if {![string is upper $initial]} { error "widgetclass \"$name\" does not begin with an uppercase letter" } if {"" != $compile(widgetclass)} { error "too many widgetclass statements" } # Next, save it. Mappend compile(defs) { set %TYPE%::Snit_info(widgetclass) %WIDGETCLASS% } %WIDGETCLASS% [list $name] set compile(widgetclass) $name } # Defines a widget's hull type. # This statement is only available for snit::widgets, # not for snit::types or snit::widgetadaptors. proc ::snit::Comp.statement.hulltype {name} { variable compile variable hulltypes # First, hulltype can only be set for true widgets if {"widget" != $compile(which)} { error "hulltype cannot be set for snit::$compile(which)s" } # Next, it must be one of the valid hulltypes (frame, toplevel, ...) if {[lsearch -exact $hulltypes [string trimleft $name :]] == -1} { error "invalid hulltype \"$name\", should be one of\ [join $hulltypes {, }]" } if {"" != $compile(hulltype)} { error "too many hulltype statements" } # Next, save it. Mappend compile(defs) { set %TYPE%::Snit_info(hulltype) %HULLTYPE% } %HULLTYPE% $name set compile(hulltype) $name } # Defines a constructor. proc ::snit::Comp.statement.constructor {arglist body} { variable compile CheckArgs "constructor" $arglist # Next, add a magic reference to self. set arglist [concat type selfns win self $arglist] # Next, add variable declarations to body: set body "%TVARDECS%%IVARDECS%\n$body" set compile(hasconstructor) yes append compile(defs) "proc %TYPE%::Snit_constructor [list $arglist] [list $body]\n" } # Defines a destructor. proc ::snit::Comp.statement.destructor {body} { variable compile # Next, add variable declarations to body: set body "%TVARDECS%%IVARDECS%\n$body" append compile(defs) "proc %TYPE%::Snit_destructor {type selfns win self} [list $body]\n\n" } # Defines a type option. The option value can be a triple, specifying # the option's -name, resource name, and class name. proc ::snit::Comp.statement.option {optionDef args} { variable compile # First, get the three option names. set option [lindex $optionDef 0] set resourceName [lindex $optionDef 1] set className [lindex $optionDef 2] set errRoot "Error in \"option [list $optionDef]...\"" # Next, validate the option name. if {![Comp.OptionNameIsValid $option]} { error "$errRoot, badly named option \"$option\"" } if {[Contains $option $compile(delegatedoptions)]} { error "$errRoot, cannot define \"$option\" locally, it has been delegated" } if {![Contains $option $compile(localoptions)]} { # Remember that we've seen this one. set compile(hasoptions) yes lappend compile(localoptions) $option # Initialize compilation info for this option. set compile(resource-$option) "" set compile(class-$option) "" set compile(-default-$option) "" set compile(-validatemethod-$option) "" set compile(-configuremethod-$option) "" set compile(-cgetmethod-$option) "" set compile(-readonly-$option) 0 set compile(-type-$option) "" } # NEXT, see if we have a resource name. If so, make sure it # isn't being redefined differently. if {"" != $resourceName} { if {"" == $compile(resource-$option)} { # If it's undefined, just save the value. set compile(resource-$option) $resourceName } elseif {![string equal $resourceName $compile(resource-$option)]} { # It's been redefined differently. error "$errRoot, resource name redefined from \"$compile(resource-$option)\" to \"$resourceName\"" } } # NEXT, see if we have a class name. If so, make sure it # isn't being redefined differently. if {"" != $className} { if {"" == $compile(class-$option)} { # If it's undefined, just save the value. set compile(class-$option) $className } elseif {![string equal $className $compile(class-$option)]} { # It's been redefined differently. error "$errRoot, class name redefined from \"$compile(class-$option)\" to \"$className\"" } } # NEXT, handle the args; it's not an error to redefine these. if {[llength $args] == 1} { set compile(-default-$option) [lindex $args 0] } else { foreach {optopt val} $args { switch -exact -- $optopt { -default - -validatemethod - -configuremethod - -cgetmethod { set compile($optopt-$option) $val } -type { set compile($optopt-$option) $val if {[llength $val] == 1} { # The type spec *is* the validation object append compile(defs) \ "\nset %TYPE%::Snit_optionInfo(typeobj-$option) [list $val]\n" } else { # Compilation the creation of the validation object set cmd [linsert $val 1 %TYPE%::Snit_TypeObj_%AUTO%] append compile(defs) \ "\nset %TYPE%::Snit_optionInfo(typeobj-$option) \[$cmd\]\n" } } -readonly { if {![string is boolean -strict $val]} { error "$errRoot, -readonly requires a boolean, got \"$val\"" } set compile($optopt-$option) $val } default { error "$errRoot, unknown option definition option \"$optopt\"" } } } } } # 1 if the option name is valid, 0 otherwise. proc ::snit::Comp.OptionNameIsValid {option} { if {![string match {-*} $option] || [string match {*[A-Z ]*} $option]} { return 0 } return 1 } # Defines an option's cget handler proc ::snit::Comp.statement.oncget {option body} { variable compile set errRoot "Error in \"oncget $option...\"" if {[lsearch -exact $compile(delegatedoptions) $option] != -1} { return -code error "$errRoot, option \"$option\" is delegated" } if {[lsearch -exact $compile(localoptions) $option] == -1} { return -code error "$errRoot, option \"$option\" unknown" } Comp.statement.method _cget$option {_option} $body Comp.statement.option $option -cgetmethod _cget$option } # Defines an option's configure handler. proc ::snit::Comp.statement.onconfigure {option arglist body} { variable compile if {[lsearch -exact $compile(delegatedoptions) $option] != -1} { return -code error "onconfigure $option: option \"$option\" is delegated" } if {[lsearch -exact $compile(localoptions) $option] == -1} { return -code error "onconfigure $option: option \"$option\" unknown" } if {[llength $arglist] != 1} { error \ "onconfigure $option handler should have one argument, got \"$arglist\"" } CheckArgs "onconfigure $option" $arglist # Next, add a magic reference to the option name set arglist [concat _option $arglist] Comp.statement.method _configure$option $arglist $body Comp.statement.option $option -configuremethod _configure$option } # Defines an instance method. proc ::snit::Comp.statement.method {method arglist body} { variable compile variable methodInfo # FIRST, check the method name against previously defined # methods. Comp.CheckMethodName $method 0 ::snit::methodInfo \ "Error in \"method [list $method]...\"" if {[llength $method] > 1} { set compile(hashierarchic) yes } # Remeber this method lappend compile(localmethods) $method CheckArgs "method [list $method]" $arglist # Next, add magic references to type and self. set arglist [concat type selfns win self $arglist] # Next, add variable declarations to body: set body "%TVARDECS%%IVARDECS%\n# END snit method prolog\n$body" # Next, save the definition script. if {[llength $method] == 1} { set methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""} Mappend compile(defs) { proc %TYPE%::Snit_method%METHOD% %ARGLIST% %BODY% } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body] } else { set methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""} Mappend compile(defs) { proc %TYPE%::Snit_hmethod%JMETHOD% %ARGLIST% %BODY% } %JMETHOD% [join $method _] %ARGLIST% [list $arglist] \ %BODY% [list $body] } } # Check for name collisions; save prefix information. # # method The name of the method or typemethod. # delFlag 1 if delegated, 0 otherwise. # infoVar The fully qualified name of the array containing # information about the defined methods. # errRoot The root string for any error messages. proc ::snit::Comp.CheckMethodName {method delFlag infoVar errRoot} { upvar $infoVar methodInfo # FIRST, make sure the method name is a valid Tcl list. if {[catch {lindex $method 0}]} { error "$errRoot, the name \"$method\" must have list syntax." } # NEXT, check whether we can define it. if {![catch {set methodInfo($method)} data]} { # We can't redefine methods with submethods. if {[lindex $data 0] == 1} { error "$errRoot, \"$method\" has submethods." } # You can't delegate a method that's defined locally, # and you can't define a method locally if it's been delegated. if {$delFlag && "" == [lindex $data 2]} { error "$errRoot, \"$method\" has been defined locally." } elseif {!$delFlag && "" != [lindex $data 2]} { error "$errRoot, \"$method\" has been delegated" } } # Handle hierarchical case. if {[llength $method] > 1} { set prefix {} set tokens $method while {[llength $tokens] > 1} { lappend prefix [lindex $tokens 0] set tokens [lrange $tokens 1 end] if {![catch {set methodInfo($prefix)} result]} { # Prefix is known. If it's not a prefix, throw an # error. if {[lindex $result 0] == 0} { error "$errRoot, \"$prefix\" has no submethods." } } set methodInfo($prefix) [list 1] } } } # Defines a typemethod method. proc ::snit::Comp.statement.typemethod {method arglist body} { variable compile variable typemethodInfo # FIRST, check the typemethod name against previously defined # typemethods. Comp.CheckMethodName $method 0 ::snit::typemethodInfo \ "Error in \"typemethod [list $method]...\"" CheckArgs "typemethod $method" $arglist # First, add magic reference to type. set arglist [concat type $arglist] # Next, add typevariable declarations to body: set body "%TVARDECS%\n# END snit method prolog\n$body" # Next, save the definition script if {[llength $method] == 1} { set typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""} Mappend compile(defs) { proc %TYPE%::Snit_typemethod%METHOD% %ARGLIST% %BODY% } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body] } else { set typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""} Mappend compile(defs) { proc %TYPE%::Snit_htypemethod%JMETHOD% %ARGLIST% %BODY% } %JMETHOD% [join $method _] \ %ARGLIST% [list $arglist] %BODY% [list $body] } } # Defines a type constructor. proc ::snit::Comp.statement.typeconstructor {body} { variable compile if {"" != $compile(typeconstructor)} { error "too many typeconstructors" } set compile(typeconstructor) $body } # Defines a static proc in the type's namespace. proc ::snit::Comp.statement.proc {proc arglist body} { variable compile # If "ns" is defined, the proc can see instance variables. if {[lsearch -exact $arglist selfns] != -1} { # Next, add instance variable declarations to body: set body "%IVARDECS%\n$body" } # The proc can always see typevariables. set body "%TVARDECS%\n$body" append compile(defs) " # Proc $proc proc [list %TYPE%::$proc $arglist $body] " } # Defines a static variable in the type's namespace. proc ::snit::Comp.statement.typevariable {name args} { variable compile set errRoot "Error in \"typevariable $name...\"" set len [llength $args] if {$len > 2 || ($len == 2 && "-array" != [lindex $args 0])} { error "$errRoot, too many initializers" } if {[lsearch -exact $compile(varnames) $name] != -1} { error "$errRoot, \"$name\" is already an instance variable" } lappend compile(typevarnames) $name if {$len == 1} { append compile(typevars) \ "\n\t [list ::variable $name [lindex $args 0]]" } elseif {$len == 2} { append compile(typevars) \ "\n\t [list ::variable $name]" append compile(typevars) \ "\n\t [list array set $name [lindex $args 1]]" } else { append compile(typevars) \ "\n\t [list ::variable $name]" } append compile(tvprocdec) "\n\t typevariable ${name}" } # Defines an instance variable; the definition will go in the # type's create typemethod. proc ::snit::Comp.statement.variable {name args} { variable compile set errRoot "Error in \"variable $name...\"" set len [llength $args] if {$len > 2 || ($len == 2 && "-array" != [lindex $args 0])} { error "$errRoot, too many initializers" } if {[lsearch -exact $compile(typevarnames) $name] != -1} { error "$errRoot, \"$name\" is already a typevariable" } lappend compile(varnames) $name if {$len == 1} { append compile(instancevars) \ "\nset \${selfns}::$name [list [lindex $args 0]]\n" } elseif {$len == 2} { append compile(instancevars) \ "\narray set \${selfns}::$name [list [lindex $args 1]]\n" } append compile(ivprocdec) "\n\t " Mappend compile(ivprocdec) {::variable ${selfns}::%N} %N $name } # Defines a typecomponent, and handles component options. # # component The logical name of the delegate # args options. proc ::snit::Comp.statement.typecomponent {component args} { variable compile set errRoot "Error in \"typecomponent $component...\"" # FIRST, define the component Comp.DefineTypecomponent $component $errRoot # NEXT, handle the options. set publicMethod "" set inheritFlag 0 foreach {opt val} $args { switch -exact -- $opt { -public { set publicMethod $val } -inherit { set inheritFlag $val if {![string is boolean $inheritFlag]} { error "typecomponent $component -inherit: expected boolean value, got \"$val\"" } } default { error "typecomponent $component: Invalid option \"$opt\"" } } } # NEXT, if -public specified, define the method. if {"" != $publicMethod} { Comp.statement.delegate typemethod [list $publicMethod *] to $component } # NEXT, if "-inherit 1" is specified, delegate typemethod * to # this component. if {$inheritFlag} { Comp.statement.delegate typemethod "*" to $component } } # Defines a name to be a typecomponent # # The name becomes a typevariable; in addition, it gets a # write trace so that when it is set, all of the component mechanisms # get updated. # # component The component name proc ::snit::Comp.DefineTypecomponent {component {errRoot "Error"}} { variable compile if {[lsearch -exact $compile(varnames) $component] != -1} { error "$errRoot, \"$component\" is already an instance variable" } if {[lsearch -exact $compile(typecomponents) $component] == -1} { # Remember we've done this. lappend compile(typecomponents) $component # Make it a type variable with no initial value Comp.statement.typevariable $component "" # Add a write trace to do the component thing. Mappend compile(typevars) { trace add variable %COMP% write \ [list ::snit::RT.TypecomponentTrace [list %TYPE%] %COMP%] } %TYPE% $compile(type) %COMP% $component } } # Defines a component, and handles component options. # # component The logical name of the delegate # args options. # # TBD: Ideally, it should be possible to call this statement multiple # times, possibly changing the option values. To do that, I'd need # to cache the option values and not act on them until *after* I'd # read the entire type definition. proc ::snit::Comp.statement.component {component args} { variable compile set errRoot "Error in \"component $component...\"" # FIRST, define the component Comp.DefineComponent $component $errRoot # NEXT, handle the options. set publicMethod "" set inheritFlag 0 foreach {opt val} $args { switch -exact -- $opt { -public { set publicMethod $val } -inherit { set inheritFlag $val if {![string is boolean $inheritFlag]} { error "component $component -inherit: expected boolean value, got \"$val\"" } } default { error "component $component: Invalid option \"$opt\"" } } } # NEXT, if -public specified, define the method. if {"" != $publicMethod} { Comp.statement.delegate method [list $publicMethod *] to $component } # NEXT, if -inherit is specified, delegate method/option * to # this component. if {$inheritFlag} { Comp.statement.delegate method "*" to $component Comp.statement.delegate option "*" to $component } } # Defines a name to be a component # # The name becomes an instance variable; in addition, it gets a # write trace so that when it is set, all of the component mechanisms # get updated. # # component The component name proc ::snit::Comp.DefineComponent {component {errRoot "Error"}} { variable compile if {[lsearch -exact $compile(typevarnames) $component] != -1} { error "$errRoot, \"$component\" is already a typevariable" } if {[lsearch -exact $compile(components) $component] == -1} { # Remember we've done this. lappend compile(components) $component # Make it an instance variable with no initial value Comp.statement.variable $component "" # Add a write trace to do the component thing. Mappend compile(instancevars) { trace add variable ${selfns}::%COMP% write \ [list ::snit::RT.ComponentTrace [list %TYPE%] $selfns %COMP%] } %TYPE% $compile(type) %COMP% $component } } # Creates a delegated method, typemethod, or option. proc ::snit::Comp.statement.delegate {what name args} { # FIRST, dispatch to correct handler. switch $what { typemethod { Comp.DelegatedTypemethod $name $args } method { Comp.DelegatedMethod $name $args } option { Comp.DelegatedOption $name $args } default { error "Error in \"delegate $what $name...\", \"$what\"?" } } if {([llength $args] % 2) != 0} { error "Error in \"delegate $what $name...\", invalid syntax" } } # Creates a delegated typemethod delegating it to a particular # typecomponent or an arbitrary command. # # method The name of the method # arglist Delegation options proc ::snit::Comp.DelegatedTypemethod {method arglist} { variable compile variable typemethodInfo set errRoot "Error in \"delegate typemethod [list $method]...\"" # Next, parse the delegation options. set component "" set target "" set exceptions {} set pattern "" set methodTail [lindex $method end] foreach {opt value} $arglist { switch -exact $opt { to { set component $value } as { set target $value } except { set exceptions $value } using { set pattern $value } default { error "$errRoot, unknown delegation option \"$opt\"" } } } if {"" == $component && "" == $pattern} { error "$errRoot, missing \"to\"" } if {"*" == $methodTail && "" != $target} { error "$errRoot, cannot specify \"as\" with \"*\"" } if {"*" != $methodTail && "" != $exceptions} { error "$errRoot, can only specify \"except\" with \"*\"" } if {"" != $pattern && "" != $target} { error "$errRoot, cannot specify both \"as\" and \"using\"" } foreach token [lrange $method 1 end-1] { if {"*" == $token} { error "$errRoot, \"*\" must be the last token." } } # NEXT, define the component if {"" != $component} { Comp.DefineTypecomponent $component $errRoot } # NEXT, define the pattern. if {"" == $pattern} { if {"*" == $methodTail} { set pattern "%c %m" } elseif {"" != $target} { set pattern "%c $target" } else { set pattern "%c %m" } } # Make sure the pattern is a valid list. if {[catch {lindex $pattern 0} result]} { error "$errRoot, the using pattern, \"$pattern\", is not a valid list" } # NEXT, check the method name against previously defined # methods. Comp.CheckMethodName $method 1 ::snit::typemethodInfo $errRoot set typemethodInfo($method) [list 0 $pattern $component] if {[string equal $methodTail "*"]} { Mappend compile(defs) { set %TYPE%::Snit_info(excepttypemethods) %EXCEPT% } %EXCEPT% [list $exceptions] } } # Creates a delegated method delegating it to a particular # component or command. # # method The name of the method # arglist Delegation options. proc ::snit::Comp.DelegatedMethod {method arglist} { variable compile variable methodInfo set errRoot "Error in \"delegate method [list $method]...\"" # Next, parse the delegation options. set component "" set target "" set exceptions {} set pattern "" set methodTail [lindex $method end] foreach {opt value} $arglist { switch -exact $opt { to { set component $value } as { set target $value } except { set exceptions $value } using { set pattern $value } default { error "$errRoot, unknown delegation option \"$opt\"" } } } if {"" == $component && "" == $pattern} { error "$errRoot, missing \"to\"" } if {"*" == $methodTail && "" != $target} { error "$errRoot, cannot specify \"as\" with \"*\"" } if {"*" != $methodTail && "" != $exceptions} { error "$errRoot, can only specify \"except\" with \"*\"" } if {"" != $pattern && "" != $target} { error "$errRoot, cannot specify both \"as\" and \"using\"" } foreach token [lrange $method 1 end-1] { if {"*" == $token} { error "$errRoot, \"*\" must be the last token." } } # NEXT, we delegate some methods set compile(delegatesmethods) yes # NEXT, define the component. Allow typecomponents. if {"" != $component} { if {[lsearch -exact $compile(typecomponents) $component] == -1} { Comp.DefineComponent $component $errRoot } } # NEXT, define the pattern. if {"" == $pattern} { if {"*" == $methodTail} { set pattern "%c %m" } elseif {"" != $target} { set pattern "%c $target" } else { set pattern "%c %m" } } # Make sure the pattern is a valid list. if {[catch {lindex $pattern 0} result]} { error "$errRoot, the using pattern, \"$pattern\", is not a valid list" } # NEXT, check the method name against previously defined # methods. Comp.CheckMethodName $method 1 ::snit::methodInfo $errRoot # NEXT, save the method info. set methodInfo($method) [list 0 $pattern $component] if {[string equal $methodTail "*"]} { Mappend compile(defs) { set %TYPE%::Snit_info(exceptmethods) %EXCEPT% } %EXCEPT% [list $exceptions] } } # Creates a delegated option, delegating it to a particular # component and, optionally, to a particular option of that # component. # # optionDef The option definition # args definition arguments. proc ::snit::Comp.DelegatedOption {optionDef arglist} { variable compile # First, get the three option names. set option [lindex $optionDef 0] set resourceName [lindex $optionDef 1] set className [lindex $optionDef 2] set errRoot "Error in \"delegate option [list $optionDef]...\"" # Next, parse the delegation options. set component "" set target "" set exceptions {} foreach {opt value} $arglist { switch -exact $opt { to { set component $value } as { set target $value } except { set exceptions $value } default { error "$errRoot, unknown delegation option \"$opt\"" } } } if {"" == $component} { error "$errRoot, missing \"to\"" } if {"*" == $option && "" != $target} { error "$errRoot, cannot specify \"as\" with \"delegate option *\"" } if {"*" != $option && "" != $exceptions} { error "$errRoot, can only specify \"except\" with \"delegate option *\"" } # Next, validate the option name if {"*" != $option} { if {![Comp.OptionNameIsValid $option]} { error "$errRoot, badly named option \"$option\"" } } if {[Contains $option $compile(localoptions)]} { error "$errRoot, \"$option\" has been defined locally" } if {[Contains $option $compile(delegatedoptions)]} { error "$errRoot, \"$option\" is multiply delegated" } # NEXT, define the component Comp.DefineComponent $component $errRoot # Next, define the target option, if not specified. if {![string equal $option "*"] && [string equal $target ""]} { set target $option } # NEXT, save the delegation data. set compile(hasoptions) yes if {![string equal $option "*"]} { lappend compile(delegatedoptions) $option # Next, compute the resource and class names, if they aren't # already defined. if {"" == $resourceName} { set resourceName [string range $option 1 end] } if {"" == $className} { set className [Capitalize $resourceName] } Mappend compile(defs) { set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 0 set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RES% set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS% lappend %TYPE%::Snit_optionInfo(delegated) %OPTION% set %TYPE%::Snit_optionInfo(target-%OPTION%) [list %COMP% %TARGET%] lappend %TYPE%::Snit_optionInfo(delegated-%COMP%) %OPTION% } %OPTION% $option \ %COMP% $component \ %TARGET% $target \ %RES% $resourceName \ %CLASS% $className } else { Mappend compile(defs) { set %TYPE%::Snit_optionInfo(starcomp) %COMP% set %TYPE%::Snit_optionInfo(except) %EXCEPT% } %COMP% $component %EXCEPT% [list $exceptions] } } # Exposes a component, effectively making the component's command an # instance method. # # component The logical name of the delegate # "as" sugar; if not "", must be "as" # methodname The desired method name for the component's command, or "" proc ::snit::Comp.statement.expose {component {"as" ""} {methodname ""}} { variable compile # FIRST, define the component Comp.DefineComponent $component # NEXT, define the method just as though it were in the type # definition. if {[string equal $methodname ""]} { set methodname $component } Comp.statement.method $methodname args [Expand { if {[llength $args] == 0} { return $%COMPONENT% } if {[string equal $%COMPONENT% ""]} { error "undefined component \"%COMPONENT%\"" } set cmd [linsert $args 0 $%COMPONENT%] return [uplevel 1 $cmd] } %COMPONENT% $component] } #----------------------------------------------------------------------- # Public commands # Compile a type definition, and return the results as a list of two # items: the fully-qualified type name, and a script that will define # the type when executed. # # which type, widget, or widgetadaptor # type the type name # body the type definition proc ::snit::compile {which type body} { return [Comp.Compile $which $type $body] } proc ::snit::type {type body} { return [Comp.Define [Comp.Compile type $type $body]] } proc ::snit::widget {type body} { return [Comp.Define [Comp.Compile widget $type $body]] } proc ::snit::widgetadaptor {type body} { return [Comp.Define [Comp.Compile widgetadaptor $type $body]] } proc ::snit::typemethod {type method arglist body} { # Make sure the type exists. if {![info exists ${type}::Snit_info]} { error "no such type: \"$type\"" } upvar ${type}::Snit_info Snit_info upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo # FIRST, check the typemethod name against previously defined # typemethods. Comp.CheckMethodName $method 0 ${type}::Snit_typemethodInfo \ "Cannot define \"$method\"" # NEXT, check the arguments CheckArgs "snit::typemethod $type $method" $arglist # Next, add magic reference to type. set arglist [concat type $arglist] # Next, add typevariable declarations to body: set body "$Snit_info(tvardecs)\n$body" # Next, define it. if {[llength $method] == 1} { set Snit_typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""} uplevel 1 [list proc ${type}::Snit_typemethod$method $arglist $body] } else { set Snit_typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""} set suffix [join $method _] uplevel 1 [list proc ${type}::Snit_htypemethod$suffix $arglist $body] } } proc ::snit::method {type method arglist body} { # Make sure the type exists. if {![info exists ${type}::Snit_info]} { error "no such type: \"$type\"" } upvar ${type}::Snit_methodInfo Snit_methodInfo upvar ${type}::Snit_info Snit_info # FIRST, check the method name against previously defined # methods. Comp.CheckMethodName $method 0 ${type}::Snit_methodInfo \ "Cannot define \"$method\"" # NEXT, check the arguments CheckArgs "snit::method $type $method" $arglist # Next, add magic references to type and self. set arglist [concat type selfns win self $arglist] # Next, add variable declarations to body: set body "$Snit_info(tvardecs)$Snit_info(ivardecs)\n$body" # Next, define it. if {[llength $method] == 1} { set Snit_methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""} uplevel 1 [list proc ${type}::Snit_method$method $arglist $body] } else { set Snit_methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""} set suffix [join $method _] uplevel 1 [list proc ${type}::Snit_hmethod$suffix $arglist $body] } } # Defines a proc within the compiler; this proc can call other # type definition statements, and thus can be used for meta-programming. proc ::snit::macro {name arglist body} { variable compiler variable reservedwords # FIRST, make sure the compiler is defined. Comp.Init # NEXT, check the macro name against the reserved words if {[lsearch -exact $reservedwords $name] != -1} { error "invalid macro name \"$name\"" } # NEXT, see if the name has a namespace; if it does, define the # namespace. set ns [namespace qualifiers $name] if {"" != $ns} { $compiler eval "namespace eval $ns {}" } # NEXT, define the macro $compiler eval [list _proc $name $arglist $body] } #----------------------------------------------------------------------- # Utility Functions # # These are utility functions used while compiling Snit types. # Builds a template from a tagged list of text blocks, then substitutes # all symbols in the mapTable, returning the expanded template. proc ::snit::Expand {template args} { return [string map $args $template] } # Expands a template and appends it to a variable. proc ::snit::Mappend {varname template args} { upvar $varname myvar append myvar [string map $args $template] } # Checks argument list against reserved args proc ::snit::CheckArgs {which arglist} { variable reservedArgs foreach name $reservedArgs { if {[Contains $name $arglist]} { error "$which's arglist may not contain \"$name\" explicitly" } } } # Returns 1 if a value is in a list, and 0 otherwise. proc ::snit::Contains {value list} { if {[lsearch -exact $list $value] != -1} { return 1 } else { return 0 } } # Capitalizes the first letter of a string. proc ::snit::Capitalize {text} { return [string toupper $text 0] } # Converts an arbitrary white-space-delimited string into a list # by splitting on white-space and deleting empty tokens. proc ::snit::Listify {str} { set result {} foreach token [split [string trim $str]] { if {[string length $token] > 0} { lappend result $token } } return $result } #======================================================================= # Snit Runtime Library # # These are procs used by Snit types and widgets at runtime. #----------------------------------------------------------------------- # Object Creation # Creates a new instance of the snit::type given its name and the args. # # type The snit::type # name The instance name # args Args to pass to the constructor proc ::snit::RT.type.typemethod.create {type name args} { variable ${type}::Snit_info variable ${type}::Snit_optionInfo # FIRST, qualify the name. if {![string match "::*" $name]} { # Get caller's namespace; # append :: if not global namespace. set ns [uplevel 1 [list namespace current]] if {"::" != $ns} { append ns "::" } set name "$ns$name" } # NEXT, if %AUTO% appears in the name, generate a unique # command name. Otherwise, ensure that the name isn't in use. if {[string match "*%AUTO%*" $name]} { set name [::snit::RT.UniqueName Snit_info(counter) $type $name] } elseif {!$Snit_info(canreplace) && [llength [info commands $name]]} { error "command \"$name\" already exists" } # NEXT, create the instance's namespace. set selfns \ [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type] namespace eval $selfns {} # NEXT, install the dispatcher RT.MakeInstanceCommand $type $selfns $name # Initialize the options to their defaults. upvar ${selfns}::options options foreach opt $Snit_optionInfo(local) { set options($opt) $Snit_optionInfo(default-$opt) } # Initialize the instance vars to their defaults. # selfns must be defined, as it is used implicitly. ${type}::Snit_instanceVars $selfns # Execute the type's constructor. set errcode [catch { RT.ConstructInstance $type $selfns $name $args } result] if {$errcode} { global errorInfo global errorCode set theInfo $errorInfo set theCode $errorCode ::snit::RT.DestroyObject $type $selfns $name error "Error in constructor: $result" $theInfo $theCode } # NEXT, return the object's name. return $name } # Creates a new instance of the snit::widget or snit::widgetadaptor # given its name and the args. # # type The snit::widget or snit::widgetadaptor # name The instance name # args Args to pass to the constructor proc ::snit::RT.widget.typemethod.create {type name args} { variable ${type}::Snit_info variable ${type}::Snit_optionInfo # FIRST, if %AUTO% appears in the name, generate a unique # command name. if {[string match "*%AUTO%*" $name]} { set name [::snit::RT.UniqueName Snit_info(counter) $type $name] } # NEXT, create the instance's namespace. set selfns \ [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type] namespace eval $selfns { } # NEXT, Initialize the widget's own options to their defaults. upvar ${selfns}::options options foreach opt $Snit_optionInfo(local) { set options($opt) $Snit_optionInfo(default-$opt) } # Initialize the instance vars to their defaults. ${type}::Snit_instanceVars $selfns # NEXT, if this is a normal widget (not a widget adaptor) then create a # frame as its hull. We set the frame's -class to the user's widgetclass, # or, if none, search for -class in the args list, otherwise default to # the basename of the $type with an initial upper case letter. if {!$Snit_info(isWidgetAdaptor)} { # FIRST, determine the class name set wclass $Snit_info(widgetclass) if {$Snit_info(widgetclass) eq ""} { set idx [lsearch -exact $args -class] if {$idx >= 0 && ($idx%2 == 0)} { # -class exists and is in the -option position set wclass [lindex $args [expr {$idx+1}]] set args [lreplace $args $idx [expr {$idx+1}]] } else { set wclass [::snit::Capitalize [namespace tail $type]] } } # NEXT, create the widget set self $name package require Tk ${type}::installhull using $Snit_info(hulltype) -class $wclass # NEXT, let's query the option database for our # widget, now that we know that it exists. foreach opt $Snit_optionInfo(local) { set dbval [RT.OptionDbGet $type $name $opt] if {"" != $dbval} { set options($opt) $dbval } } } # Execute the type's constructor, and verify that it # has a hull. set errcode [catch { RT.ConstructInstance $type $selfns $name $args ::snit::RT.Component $type $selfns hull # Prepare to call the object's destructor when the # event is received. Use a Snit-specific bindtag # so that the widget name's tag is unencumbered. bind Snit$type$name [::snit::Expand { ::snit::RT.DestroyObject %TYPE% %NS% %W } %TYPE% $type %NS% $selfns] # Insert the bindtag into the list of bindtags right # after the widget name. set taglist [bindtags $name] set ndx [lsearch -exact $taglist $name] incr ndx bindtags $name [linsert $taglist $ndx Snit$type$name] } result] if {$errcode} { global errorInfo global errorCode set theInfo $errorInfo set theCode $errorCode ::snit::RT.DestroyObject $type $selfns $name error "Error in constructor: $result" $theInfo $theCode } # NEXT, return the object's name. return $name } # RT.MakeInstanceCommand type selfns instance # # type The object type # selfns The instance namespace # instance The instance name # # Creates the instance proc. proc ::snit::RT.MakeInstanceCommand {type selfns instance} { variable ${type}::Snit_info # FIRST, remember the instance name. The Snit_instance variable # allows the instance to figure out its current name given the # instance namespace. upvar ${selfns}::Snit_instance Snit_instance set Snit_instance $instance # NEXT, qualify the proc name if it's a widget. if {$Snit_info(isWidget)} { set procname ::$instance } else { set procname $instance } # NEXT, install the new proc if {!$Snit_info(simpledispatch)} { set instanceProc $::snit::nominalInstanceProc } else { set instanceProc $::snit::simpleInstanceProc } proc $procname {method args} \ [string map \ [list %SELFNS% $selfns %WIN% $instance %TYPE% $type] \ $instanceProc] # NEXT, add the trace. trace add command $procname {rename delete} \ [list ::snit::RT.InstanceTrace $type $selfns $instance] } # This proc is called when the instance command is renamed. # If op is delete, then new will always be "", so op is redundant. # # type The fully-qualified type name # selfns The instance namespace # win The original instance/tk window name. # old old instance command name # new new instance command name # op rename or delete # # If the op is delete, we need to clean up the object; otherwise, # we need to track the change. # # NOTE: In Tcl 8.4.2 there's a bug: errors in rename and delete # traces aren't propagated correctly. Instead, they silently # vanish. Add a catch to output any error message. proc ::snit::RT.InstanceTrace {type selfns win old new op} { variable ${type}::Snit_info # Note to developers ... # For Tcl 8.4.0, errors thrown in trace handlers vanish silently. # Therefore we catch them here and create some output to help in # debugging such problems. if {[catch { # FIRST, clean up if necessary if {"" == $new} { if {$Snit_info(isWidget)} { destroy $win } else { ::snit::RT.DestroyObject $type $selfns $win } } else { # Otherwise, track the change. variable ${selfns}::Snit_instance set Snit_instance [uplevel 1 [list namespace which -command $new]] # Also, clear the instance caches, as many cached commands # might be invalid. RT.ClearInstanceCaches $selfns } } result]} { global errorInfo # Pop up the console on Windows wish, to enable stdout. # This clobbers errorInfo on unix, so save it so we can print it. set ei $errorInfo catch {console show} puts "Error in ::snit::RT.InstanceTrace $type $selfns $win $old $new $op:" puts $ei } } # Calls the instance constructor and handles related housekeeping. proc ::snit::RT.ConstructInstance {type selfns instance arglist} { variable ${type}::Snit_optionInfo variable ${selfns}::Snit_iinfo # Track whether we are constructed or not. set Snit_iinfo(constructed) 0 # Call the user's constructor eval [linsert $arglist 0 \ ${type}::Snit_constructor $type $selfns $instance $instance] set Snit_iinfo(constructed) 1 # Validate the initial set of options (including defaults) foreach option $Snit_optionInfo(local) { set value [set ${selfns}::options($option)] if {"" != $Snit_optionInfo(typespec-$option)} { if {[catch { $Snit_optionInfo(typeobj-$option) validate $value } result]} { return -code error "invalid $option default: $result" } } } # Unset the configure cache for all -readonly options. # This ensures that the next time anyone tries to # configure it, an error is thrown. foreach opt $Snit_optionInfo(local) { if {$Snit_optionInfo(readonly-$opt)} { unset -nocomplain ${selfns}::Snit_configureCache($opt) } } return } # Returns a unique command name. # # REQUIRE: type is a fully qualified name. # REQUIRE: name contains "%AUTO%" # PROMISE: the returned command name is unused. proc ::snit::RT.UniqueName {countervar type name} { upvar $countervar counter while 1 { # FIRST, bump the counter and define the %AUTO% instance name; # then substitute it into the specified name. Wrap around at # 2^31 - 2 to prevent overflow problems. incr counter if {$counter > 2147483646} { set counter 0 } set auto "[namespace tail $type]$counter" set candidate [Expand $name %AUTO% $auto] if {![llength [info commands $candidate]]} { return $candidate } } } # Returns a unique instance namespace, fully qualified. # # countervar The name of a counter variable # type The instance's type # # REQUIRE: type is fully qualified # PROMISE: The returned namespace name is unused. proc ::snit::RT.UniqueInstanceNamespace {countervar type} { upvar $countervar counter while 1 { # FIRST, bump the counter and define the namespace name. # Then see if it already exists. Wrap around at # 2^31 - 2 to prevent overflow problems. incr counter if {$counter > 2147483646} { set counter 0 } set ins "${type}::Snit_inst${counter}" if {![namespace exists $ins]} { return $ins } } } # Retrieves an option's value from the option database. # Returns "" if no value is found. proc ::snit::RT.OptionDbGet {type self opt} { variable ${type}::Snit_optionInfo return [option get $self \ $Snit_optionInfo(resource-$opt) \ $Snit_optionInfo(class-$opt)] } #----------------------------------------------------------------------- # Object Destruction # Implements the standard "destroy" method # # type The snit type # selfns The instance's instance namespace # win The instance's original name # self The instance's current name proc ::snit::RT.method.destroy {type selfns win self} { variable ${selfns}::Snit_iinfo # Can't destroy the object if it isn't complete constructed. if {!$Snit_iinfo(constructed)} { return -code error "Called 'destroy' method in constructor" } # Calls Snit_cleanup, which (among other things) calls the # user's destructor. ::snit::RT.DestroyObject $type $selfns $win } # This is the function that really cleans up; it's automatically # called when any instance is destroyed, e.g., by "$object destroy" # for types, and by the event for widgets. # # type The fully-qualified type name. # selfns The instance namespace # win The original instance command name. proc ::snit::RT.DestroyObject {type selfns win} { variable ${type}::Snit_info # If the variable Snit_instance doesn't exist then there's no # instance command for this object -- it's most likely a # widgetadaptor. Consequently, there are some things that # we don't need to do. if {[info exists ${selfns}::Snit_instance]} { upvar ${selfns}::Snit_instance instance # First, remove the trace on the instance name, so that we # don't call RT.DestroyObject recursively. RT.RemoveInstanceTrace $type $selfns $win $instance # Next, call the user's destructor ${type}::Snit_destructor $type $selfns $win $instance # Next, if this isn't a widget, delete the instance command. # If it is a widget, get the hull component's name, and rename # it back to the widget name # Next, delete the hull component's instance command, # if there is one. if {$Snit_info(isWidget)} { set hullcmd [::snit::RT.Component $type $selfns hull] catch {rename $instance ""} # Clear the bind event bind Snit$type$win "" if {[llength [info commands $hullcmd]]} { # FIRST, rename the hull back to its original name. # If the hull is itself a megawidget, it will have its # own cleanup to do, and it might not do it properly # if it doesn't have the right name. rename $hullcmd ::$instance # NEXT, destroy it. destroy $instance } } else { catch {rename $instance ""} } } # Next, delete the instance's namespace. This kills any # instance variables. namespace delete $selfns return } # Remove instance trace # # type The fully qualified type name # selfns The instance namespace # win The original instance name/Tk window name # instance The current instance name proc ::snit::RT.RemoveInstanceTrace {type selfns win instance} { variable ${type}::Snit_info if {$Snit_info(isWidget)} { set procname ::$instance } else { set procname $instance } # NEXT, remove any trace on this name catch { trace remove command $procname {rename delete} \ [list ::snit::RT.InstanceTrace $type $selfns $win] } } #----------------------------------------------------------------------- # Typecomponent Management and Method Caching # Typecomponent trace; used for write trace on typecomponent # variables. Saves the new component object name, provided # that certain conditions are met. Also clears the typemethod # cache. proc ::snit::RT.TypecomponentTrace {type component n1 n2 op} { upvar ${type}::Snit_info Snit_info upvar ${type}::${component} cvar upvar ${type}::Snit_typecomponents Snit_typecomponents # Save the new component value. set Snit_typecomponents($component) $cvar # Clear the typemethod cache. # TBD: can we unset just the elements related to # this component? unset -nocomplain -- ${type}::Snit_typemethodCache } # Generates and caches the command for a typemethod. # # type The type # method The name of the typemethod to call. # # The return value is one of the following lists: # # {} There's no such method. # {1} The method has submethods; look again. # {0 } Here's the command to execute. proc snit::RT.CacheTypemethodCommand {type method} { upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo upvar ${type}::Snit_typecomponents Snit_typecomponents upvar ${type}::Snit_typemethodCache Snit_typemethodCache upvar ${type}::Snit_info Snit_info # FIRST, get the pattern data and the typecomponent name. set implicitCreate 0 set instanceName "" set starredMethod [lreplace $method end end *] set methodTail [lindex $method end] if {[info exists Snit_typemethodInfo($method)]} { set key $method } elseif {[info exists Snit_typemethodInfo($starredMethod)]} { if {[lsearch -exact $Snit_info(excepttypemethods) $methodTail] == -1} { set key $starredMethod } else { return [list ] } } elseif {[llength $method] > 1} { return [list ] } elseif {$Snit_info(hasinstances)} { # Assume the unknown name is an instance name to create, unless # this is a widget and the style of the name is wrong, or the # name mimics a standard typemethod. if {[set ${type}::Snit_info(isWidget)] && ![string match ".*" $method]} { return [list ] } # Without this check, the call "$type info" will redefine the # standard "::info" command, with disastrous results. Since it's # a likely thing to do if !-typeinfo, put in an explicit check. if {"info" == $method || "destroy" == $method} { return [list ] } set implicitCreate 1 set instanceName $method set key create set method create } else { return [list ] } foreach {flag pattern compName} $Snit_typemethodInfo($key) {} if {$flag == 1} { return [list 1] } # NEXT, build the substitution list set subList [list \ %% % \ %t $type \ %M $method \ %m [lindex $method end] \ %j [join $method _]] if {"" != $compName} { if {![info exists Snit_typecomponents($compName)]} { error "$type delegates typemethod \"$method\" to undefined typecomponent \"$compName\"" } lappend subList %c [list $Snit_typecomponents($compName)] } set command {} foreach subpattern $pattern { lappend command [string map $subList $subpattern] } if {$implicitCreate} { # In this case, $method is the name of the instance to # create. Don't cache, as we usually won't do this one # again. lappend command $instanceName } else { set Snit_typemethodCache($method) [list 0 $command] } return [list 0 $command] } #----------------------------------------------------------------------- # Component Management and Method Caching # Retrieves the object name given the component name. proc ::snit::RT.Component {type selfns name} { variable ${selfns}::Snit_components if {[catch {set Snit_components($name)} result]} { variable ${selfns}::Snit_instance error "component \"$name\" is undefined in $type $Snit_instance" } return $result } # Component trace; used for write trace on component instance # variables. Saves the new component object name, provided # that certain conditions are met. Also clears the method # cache. proc ::snit::RT.ComponentTrace {type selfns component n1 n2 op} { upvar ${type}::Snit_info Snit_info upvar ${selfns}::${component} cvar upvar ${selfns}::Snit_components Snit_components # If they try to redefine the hull component after # it's been defined, that's an error--but only if # this is a widget or widget adaptor. if {"hull" == $component && $Snit_info(isWidget) && [info exists Snit_components($component)]} { set cvar $Snit_components($component) error "The hull component cannot be redefined" } # Save the new component value. set Snit_components($component) $cvar # Clear the instance caches. # TBD: can we unset just the elements related to # this component? RT.ClearInstanceCaches $selfns } # Generates and caches the command for a method. # # type: The instance's type # selfns: The instance's private namespace # win: The instance's original name (a Tk widget name, for # snit::widgets. # self: The instance's current name. # method: The name of the method to call. # # The return value is one of the following lists: # # {} There's no such method. # {1} The method has submethods; look again. # {0 } Here's the command to execute. proc ::snit::RT.CacheMethodCommand {type selfns win self method} { variable ${type}::Snit_info variable ${type}::Snit_methodInfo variable ${type}::Snit_typecomponents variable ${selfns}::Snit_components variable ${selfns}::Snit_methodCache # FIRST, get the pattern data and the component name. set starredMethod [lreplace $method end end *] set methodTail [lindex $method end] if {[info exists Snit_methodInfo($method)]} { set key $method } elseif {[info exists Snit_methodInfo($starredMethod)] && [lsearch -exact $Snit_info(exceptmethods) $methodTail] == -1} { set key $starredMethod } else { return [list ] } foreach {flag pattern compName} $Snit_methodInfo($key) {} if {$flag == 1} { return [list 1] } # NEXT, build the substitution list set subList [list \ %% % \ %t $type \ %M $method \ %m [lindex $method end] \ %j [join $method _] \ %n [list $selfns] \ %w [list $win] \ %s [list $self]] if {"" != $compName} { if {[info exists Snit_components($compName)]} { set compCmd $Snit_components($compName) } elseif {[info exists Snit_typecomponents($compName)]} { set compCmd $Snit_typecomponents($compName) } else { error "$type $self delegates method \"$method\" to undefined component \"$compName\"" } lappend subList %c [list $compCmd] } # Note: The cached command will executed faster if it's # already a list. set command {} foreach subpattern $pattern { lappend command [string map $subList $subpattern] } set commandRec [list 0 $command] set Snit_methodCache($method) $commandRec return $commandRec } # Looks up a method's command. # # type: The instance's type # selfns: The instance's private namespace # win: The instance's original name (a Tk widget name, for # snit::widgets. # self: The instance's current name. # method: The name of the method to call. # errPrefix: Prefix for any error method proc ::snit::RT.LookupMethodCommand {type selfns win self method errPrefix} { set commandRec [snit::RT.CacheMethodCommand \ $type $selfns $win $self \ $method] if {[llength $commandRec] == 0} { return -code error \ "$errPrefix, \"$self $method\" is not defined" } elseif {[lindex $commandRec 0] == 1} { return -code error \ "$errPrefix, wrong number args: should be \"$self\" $method method args" } return [lindex $commandRec 1] } # Clears all instance command caches proc ::snit::RT.ClearInstanceCaches {selfns} { unset -nocomplain -- ${selfns}::Snit_methodCache unset -nocomplain -- ${selfns}::Snit_cgetCache unset -nocomplain -- ${selfns}::Snit_configureCache unset -nocomplain -- ${selfns}::Snit_validateCache } #----------------------------------------------------------------------- # Component Installation # Implements %TYPE%::installhull. The variables self and selfns # must be defined in the caller's context. # # Installs the named widget as the hull of a # widgetadaptor. Once the widget is hijacked, its new name # is assigned to the hull component. proc ::snit::RT.installhull {type {using "using"} {widgetType ""} args} { variable ${type}::Snit_info variable ${type}::Snit_optionInfo upvar self self upvar selfns selfns upvar ${selfns}::hull hull upvar ${selfns}::options options # FIRST, make sure we can do it. if {!$Snit_info(isWidget)} { error "installhull is valid only for snit::widgetadaptors" } if {[info exists ${selfns}::Snit_instance]} { error "hull already installed for $type $self" } # NEXT, has it been created yet? If not, create it using # the specified arguments. if {"using" == $using} { # FIRST, create the widget set cmd [linsert $args 0 $widgetType $self] set obj [uplevel 1 $cmd] # NEXT, for each option explicitly delegated to the hull # that doesn't appear in the usedOpts list, get the # option database value and apply it--provided that the # real option name and the target option name are different. # (If they are the same, then the option database was # already queried as part of the normal widget creation.) # # Also, we don't need to worry about implicitly delegated # options, as the option and target option names must be # the same. if {[info exists Snit_optionInfo(delegated-hull)]} { # FIRST, extract all option names from args set usedOpts {} set ndx [lsearch -glob $args "-*"] foreach {opt val} [lrange $args $ndx end] { lappend usedOpts $opt } foreach opt $Snit_optionInfo(delegated-hull) { set target [lindex $Snit_optionInfo(target-$opt) 1] if {"$target" == $opt} { continue } set result [lsearch -exact $usedOpts $target] if {$result != -1} { continue } set dbval [RT.OptionDbGet $type $self $opt] $obj configure $target $dbval } } } else { set obj $using if {![string equal $obj $self]} { error \ "hull name mismatch: \"$obj\" != \"$self\"" } } # NEXT, get the local option defaults. foreach opt $Snit_optionInfo(local) { set dbval [RT.OptionDbGet $type $self $opt] if {"" != $dbval} { set options($opt) $dbval } } # NEXT, do the magic set i 0 while 1 { incr i set newName "::hull${i}$self" if {![llength [info commands $newName]]} { break } } rename ::$self $newName RT.MakeInstanceCommand $type $selfns $self # Note: this relies on RT.ComponentTrace to do the dirty work. set hull $newName return } # Implements %TYPE%::install. # # Creates a widget and installs it as the named component. # It expects self and selfns to be defined in the caller's context. proc ::snit::RT.install {type compName "using" widgetType winPath args} { variable ${type}::Snit_optionInfo variable ${type}::Snit_info upvar self self upvar selfns selfns upvar ${selfns}::$compName comp upvar ${selfns}::hull hull # We do the magic option database stuff only if $self is # a widget. if {$Snit_info(isWidget)} { if {"" == $hull} { error "tried to install \"$compName\" before the hull exists" } # FIRST, query the option database and save the results # into args. Insert them before the first option in the # list, in case there are any non-standard parameters. # # Note: there might not be any delegated options; if so, # don't bother. if {[info exists Snit_optionInfo(delegated-$compName)]} { set ndx [lsearch -glob $args "-*"] foreach opt $Snit_optionInfo(delegated-$compName) { set dbval [RT.OptionDbGet $type $self $opt] if {"" != $dbval} { set target [lindex $Snit_optionInfo(target-$opt) 1] set args [linsert $args $ndx $target $dbval] } } } } # NEXT, create the component and save it. set cmd [concat [list $widgetType $winPath] $args] set comp [uplevel 1 $cmd] # NEXT, handle the option database for "delegate option *", # in widgets only. if {$Snit_info(isWidget) && [string equal $Snit_optionInfo(starcomp) $compName]} { # FIRST, get the list of option specs from the widget. # If configure doesn't work, skip it. if {[catch {$comp configure} specs]} { return } # NEXT, get the set of explicitly used options from args set usedOpts {} set ndx [lsearch -glob $args "-*"] foreach {opt val} [lrange $args $ndx end] { lappend usedOpts $opt } # NEXT, "delegate option *" matches all options defined # by this widget that aren't defined by the widget as a whole, # and that aren't excepted. Plus, we skip usedOpts. So build # a list of the options it can't match. set skiplist [concat \ $usedOpts \ $Snit_optionInfo(except) \ $Snit_optionInfo(local) \ $Snit_optionInfo(delegated)] # NEXT, loop over all of the component's options, and set # any not in the skip list for which there is an option # database value. foreach spec $specs { # Skip aliases if {[llength $spec] != 5} { continue } set opt [lindex $spec 0] if {[lsearch -exact $skiplist $opt] != -1} { continue } set res [lindex $spec 1] set cls [lindex $spec 2] set dbvalue [option get $self $res $cls] if {"" != $dbvalue} { $comp configure $opt $dbvalue } } } return } #----------------------------------------------------------------------- # Method/Variable Name Qualification # Implements %TYPE%::variable. Requires selfns. proc ::snit::RT.variable {varname} { upvar selfns selfns if {![string match "::*" $varname]} { uplevel 1 [list upvar 1 ${selfns}::$varname $varname] } else { # varname is fully qualified; let the standard # "variable" command handle it. uplevel 1 [list ::variable $varname] } } # Fully qualifies a typevariable name. # # This is used to implement the mytypevar command. proc ::snit::RT.mytypevar {type name} { return ${type}::$name } # Fully qualifies an instance variable name. # # This is used to implement the myvar command. proc ::snit::RT.myvar {name} { upvar selfns selfns return ${selfns}::$name } # Use this like "list" to convert a proc call into a command # string to pass to another object (e.g., as a -command). # Qualifies the proc name properly. # # This is used to implement the "myproc" command. proc ::snit::RT.myproc {type procname args} { set procname "${type}::$procname" return [linsert $args 0 $procname] } # DEPRECATED proc ::snit::RT.codename {type name} { return "${type}::$name" } # Use this like "list" to convert a typemethod call into a command # string to pass to another object (e.g., as a -command). # Inserts the type command at the beginning. # # This is used to implement the "mytypemethod" command. proc ::snit::RT.mytypemethod {type args} { return [linsert $args 0 $type] } # Use this like "list" to convert a method call into a command # string to pass to another object (e.g., as a -command). # Inserts the code at the beginning to call the right object, even if # the object's name has changed. Requires that selfns be defined # in the calling context, eg. can only be called in instance # code. # # This is used to implement the "mymethod" command. proc ::snit::RT.mymethod {args} { upvar selfns selfns return [linsert $args 0 ::snit::RT.CallInstance ${selfns}] } # Calls an instance method for an object given its # instance namespace and remaining arguments (the first of which # will be the method name. # # selfns The instance namespace # args The arguments # # Uses the selfns to determine $self, and calls the method # in the normal way. # # This is used to implement the "mymethod" command. proc ::snit::RT.CallInstance {selfns args} { upvar ${selfns}::Snit_instance self set retval [catch {uplevel 1 [linsert $args 0 $self]} result] if {$retval} { if {$retval == 1} { global errorInfo global errorCode return -code error -errorinfo $errorInfo \ -errorcode $errorCode $result } else { return -code $retval $result } } return $result } # Looks for the named option in the named variable. If found, # it and its value are removed from the list, and the value # is returned. Otherwise, the default value is returned. # If the option is undelegated, it's own default value will be # used if none is specified. # # Implements the "from" command. proc ::snit::RT.from {type argvName option {defvalue ""}} { variable ${type}::Snit_optionInfo upvar $argvName argv set ioption [lsearch -exact $argv $option] if {$ioption == -1} { if {"" == $defvalue && [info exists Snit_optionInfo(default-$option)]} { return $Snit_optionInfo(default-$option) } else { return $defvalue } } set ivalue [expr {$ioption + 1}] set value [lindex $argv $ivalue] set argv [lreplace $argv $ioption $ivalue] return $value } #----------------------------------------------------------------------- # Type Destruction # Implements the standard "destroy" typemethod: # Destroys a type completely. # # type The snit type proc ::snit::RT.typemethod.destroy {type} { variable ${type}::Snit_info # FIRST, destroy all instances foreach selfns [namespace children $type "${type}::Snit_inst*"] { if {![namespace exists $selfns]} { continue } upvar ${selfns}::Snit_instance obj if {$Snit_info(isWidget)} { destroy $obj } else { if {[llength [info commands $obj]]} { $obj destroy } } } # NEXT, destroy the type's data. namespace delete $type # NEXT, get rid of the type command. rename $type "" } #----------------------------------------------------------------------- # Option Handling # Implements the standard "cget" method # # type The snit type # selfns The instance's instance namespace # win The instance's original name # self The instance's current name # option The name of the option proc ::snit::RT.method.cget {type selfns win self option} { if {[catch {set ${selfns}::Snit_cgetCache($option)} command]} { set command [snit::RT.CacheCgetCommand $type $selfns $win $self $option] if {[llength $command] == 0} { return -code error "unknown option \"$option\"" } } uplevel 1 $command } # Retrieves and caches the command that implements "cget" for the # specified option. # # type The snit type # selfns The instance's instance namespace # win The instance's original name # self The instance's current name # option The name of the option proc ::snit::RT.CacheCgetCommand {type selfns win self option} { variable ${type}::Snit_optionInfo variable ${selfns}::Snit_cgetCache if {[info exists Snit_optionInfo(islocal-$option)]} { # We know the item; it's either local, or explicitly delegated. if {$Snit_optionInfo(islocal-$option)} { # It's a local option. If it has a cget method defined, # use it; otherwise just return the value. if {"" == $Snit_optionInfo(cget-$option)} { set command [list set ${selfns}::options($option)] } else { set command [snit::RT.LookupMethodCommand \ $type $selfns $win $self \ $Snit_optionInfo(cget-$option) \ "can't cget $option"] lappend command $option } set Snit_cgetCache($option) $command return $command } # Explicitly delegated option; get target set comp [lindex $Snit_optionInfo(target-$option) 0] set target [lindex $Snit_optionInfo(target-$option) 1] } elseif {"" != $Snit_optionInfo(starcomp) && [lsearch -exact $Snit_optionInfo(except) $option] == -1} { # Unknown option, but unknowns are delegated; get target. set comp $Snit_optionInfo(starcomp) set target $option } else { return "" } # Get the component's object. set obj [RT.Component $type $selfns $comp] set command [list $obj cget $target] set Snit_cgetCache($option) $command return $command } # Implements the standard "configurelist" method # # type The snit type # selfns The instance's instance namespace # win The instance's original name # self The instance's current name # optionlist A list of options and their values. proc ::snit::RT.method.configurelist {type selfns win self optionlist} { variable ${type}::Snit_optionInfo foreach {option value} $optionlist { # FIRST, get the configure command, caching it if need be. if {[catch {set ${selfns}::Snit_configureCache($option)} command]} { set command [snit::RT.CacheConfigureCommand \ $type $selfns $win $self $option] if {[llength $command] == 0} { return -code error "unknown option \"$option\"" } } # NEXT, if we have a type-validation object, use it. # TBD: Should test (islocal-$option) here, but islocal # isn't defined for implicitly delegated options. if {[info exists Snit_optionInfo(typeobj-$option)] && "" != $Snit_optionInfo(typeobj-$option)} { if {[catch { $Snit_optionInfo(typeobj-$option) validate $value } result]} { return -code error "invalid $option value: $result" } } # NEXT, the caching the configure command also cached the # validate command, if any. If we have one, run it. set valcommand [set ${selfns}::Snit_validateCache($option)] if {[llength $valcommand]} { lappend valcommand $value uplevel 1 $valcommand } # NEXT, configure the option with the value. lappend command $value uplevel 1 $command } return } # Retrieves and caches the command that stores the named option. # Also stores the command that validates the name option if any; # If none, the validate command is "", so that the cache is always # populated. # # type The snit type # selfns The instance's instance namespace # win The instance's original name # self The instance's current name # option An option name proc ::snit::RT.CacheConfigureCommand {type selfns win self option} { variable ${type}::Snit_optionInfo variable ${selfns}::Snit_configureCache variable ${selfns}::Snit_validateCache if {[info exist Snit_optionInfo(islocal-$option)]} { # We know the item; it's either local, or explicitly delegated. if {$Snit_optionInfo(islocal-$option)} { # It's a local option. # If it's readonly, it throws an error if we're already # constructed. if {$Snit_optionInfo(readonly-$option)} { if {[set ${selfns}::Snit_iinfo(constructed)]} { error "option $option can only be set at instance creation" } } # If it has a validate method, cache that for later. if {"" != $Snit_optionInfo(validate-$option)} { set command [snit::RT.LookupMethodCommand \ $type $selfns $win $self \ $Snit_optionInfo(validate-$option) \ "can't validate $option"] lappend command $option set Snit_validateCache($option) $command } else { set Snit_validateCache($option) "" } # If it has a configure method defined, # cache it; otherwise, just set the value. if {"" == $Snit_optionInfo(configure-$option)} { set command [list set ${selfns}::options($option)] } else { set command [snit::RT.LookupMethodCommand \ $type $selfns $win $self \ $Snit_optionInfo(configure-$option) \ "can't configure $option"] lappend command $option } set Snit_configureCache($option) $command return $command } # Delegated option: get target. set comp [lindex $Snit_optionInfo(target-$option) 0] set target [lindex $Snit_optionInfo(target-$option) 1] } elseif {$Snit_optionInfo(starcomp) != "" && [lsearch -exact $Snit_optionInfo(except) $option] == -1} { # Unknown option, but unknowns are delegated. set comp $Snit_optionInfo(starcomp) set target $option } else { return "" } # There is no validate command in this case; save an empty string. set Snit_validateCache($option) "" # Get the component's object set obj [RT.Component $type $selfns $comp] set command [list $obj configure $target] set Snit_configureCache($option) $command return $command } # Implements the standard "configure" method # # type The snit type # selfns The instance's instance namespace # win The instance's original name # self The instance's current name # args A list of options and their values, possibly empty. proc ::snit::RT.method.configure {type selfns win self args} { # If two or more arguments, set values as usual. if {[llength $args] >= 2} { ::snit::RT.method.configurelist $type $selfns $win $self $args return } # If zero arguments, acquire data for each known option # and return the list if {[llength $args] == 0} { set result {} foreach opt [RT.method.info.options $type $selfns $win $self] { # Refactor this, so that we don't need to call via $self. lappend result [RT.GetOptionDbSpec \ $type $selfns $win $self $opt] } return $result } # They want it for just one. set opt [lindex $args 0] return [RT.GetOptionDbSpec $type $selfns $win $self $opt] } # Retrieves the option database spec for a single option. # # type The snit type # selfns The instance's instance namespace # win The instance's original name # self The instance's current name # option The name of an option # # TBD: This is a bad name. What it's returning is the # result of the configure query. proc ::snit::RT.GetOptionDbSpec {type selfns win self opt} { variable ${type}::Snit_optionInfo upvar ${selfns}::Snit_components Snit_components upvar ${selfns}::options options if {[info exists options($opt)]} { # This is a locally-defined option. Just build the # list and return it. set res $Snit_optionInfo(resource-$opt) set cls $Snit_optionInfo(class-$opt) set def $Snit_optionInfo(default-$opt) return [list $opt $res $cls $def \ [RT.method.cget $type $selfns $win $self $opt]] } elseif {[info exists Snit_optionInfo(target-$opt)]} { # This is an explicitly delegated option. The only # thing we don't have is the default. set res $Snit_optionInfo(resource-$opt) set cls $Snit_optionInfo(class-$opt) # Get the default set logicalName [lindex $Snit_optionInfo(target-$opt) 0] set comp $Snit_components($logicalName) set target [lindex $Snit_optionInfo(target-$opt) 1] if {[catch {$comp configure $target} result]} { set defValue {} } else { set defValue [lindex $result 3] } return [list $opt $res $cls $defValue [$self cget $opt]] } elseif {"" != $Snit_optionInfo(starcomp) && [lsearch -exact $Snit_optionInfo(except) $opt] == -1} { set logicalName $Snit_optionInfo(starcomp) set target $opt set comp $Snit_components($logicalName) if {[catch {set value [$comp cget $target]} result]} { error "unknown option \"$opt\"" } if {![catch {$comp configure $target} result]} { # Replace the delegated option name with the local name. return [::snit::Expand $result $target $opt] } # configure didn't work; return simple form. return [list $opt "" "" "" $value] } else { error "unknown option \"$opt\"" } } #----------------------------------------------------------------------- # Type Introspection # Implements the standard "info" typemethod. # # type The snit type # command The info subcommand # args All other arguments. proc ::snit::RT.typemethod.info {type command args} { global errorInfo global errorCode switch -exact $command { args - body - default - typevars - typemethods - instances { # TBD: it should be possible to delete this error # handling. set errflag [catch { uplevel 1 [linsert $args 0 \ ::snit::RT.typemethod.info.$command $type] } result] if {$errflag} { return -code error -errorinfo $errorInfo \ -errorcode $errorCode $result } else { return $result } } default { error "\"$type info $command\" is not defined" } } } # Returns a list of the type's typevariables whose names match a # pattern, excluding Snit internal variables. # # type A Snit type # pattern Optional. The glob pattern to match. Defaults # to *. proc ::snit::RT.typemethod.info.typevars {type {pattern *}} { set result {} foreach name [info vars "${type}::$pattern"] { set tail [namespace tail $name] if {![string match "Snit_*" $tail]} { lappend result $name } } return $result } # Returns a list of the type's methods whose names match a # pattern. If "delegate typemethod *" is used, the list may # not be complete. # # type A Snit type # pattern Optional. The glob pattern to match. Defaults # to *. proc ::snit::RT.typemethod.info.typemethods {type {pattern *}} { variable ${type}::Snit_typemethodInfo variable ${type}::Snit_typemethodCache # FIRST, get the explicit names, skipping prefixes. set result {} foreach name [array names Snit_typemethodInfo $pattern] { if {[lindex $Snit_typemethodInfo($name) 0] != 1} { lappend result $name } } # NEXT, add any from the cache that aren't explicit. if {[info exists Snit_typemethodInfo(*)]} { # First, remove "*" from the list. set ndx [lsearch -exact $result "*"] if {$ndx != -1} { set result [lreplace $result $ndx $ndx] } foreach name [array names Snit_typemethodCache $pattern] { if {[lsearch -exact $result $name] == -1} { lappend result $name } } } return $result } # $type info args # # Returns a method's list of arguments. does not work for delegated # methods, nor for the internal dispatch methods of multi-word # methods. proc ::snit::RT.typemethod.info.args {type method} { upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo # Snit_methodInfo: method -> list (flag cmd component) # flag : 1 -> internal dispatcher for multi-word method. # 0 -> regular method # # cmd : template mapping from method to command prefix, may # contain placeholders for various pieces of information. # # component : is empty for normal methods. #parray Snit_typemethodInfo if {![info exists Snit_typemethodInfo($method)]} { return -code error "Unknown typemethod \"$method\"" } foreach {flag cmd component} $Snit_typemethodInfo($method) break if {$flag} { return -code error "Unknown typemethod \"$method\"" } if {$component != ""} { return -code error "Delegated typemethod \"$method\"" } set map [list %m $method %j [join $method _] %t $type] set theproc [lindex [string map $map $cmd] 0] return [lrange [::info args $theproc] 1 end] } # $type info body # # Returns a method's body. does not work for delegated # methods, nor for the internal dispatch methods of multi-word # methods. proc ::snit::RT.typemethod.info.body {type method} { upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo # Snit_methodInfo: method -> list (flag cmd component) # flag : 1 -> internal dispatcher for multi-word method. # 0 -> regular method # # cmd : template mapping from method to command prefix, may # contain placeholders for various pieces of information. # # component : is empty for normal methods. #parray Snit_typemethodInfo if {![info exists Snit_typemethodInfo($method)]} { return -code error "Unknown typemethod \"$method\"" } foreach {flag cmd component} $Snit_typemethodInfo($method) break if {$flag} { return -code error "Unknown typemethod \"$method\"" } if {$component != ""} { return -code error "Delegated typemethod \"$method\"" } set map [list %m $method %j [join $method _] %t $type] set theproc [lindex [string map $map $cmd] 0] return [RT.body [::info body $theproc]] } # $type info default # # Returns a method's list of arguments. does not work for delegated # methods, nor for the internal dispatch methods of multi-word # methods. proc ::snit::RT.typemethod.info.default {type method aname dvar} { upvar 1 $dvar def upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo # Snit_methodInfo: method -> list (flag cmd component) # flag : 1 -> internal dispatcher for multi-word method. # 0 -> regular method # # cmd : template mapping from method to command prefix, may # contain placeholders for various pieces of information. # # component : is empty for normal methods. #parray Snit_methodInfo if {![info exists Snit_typemethodInfo($method)]} { return -code error "Unknown typemethod \"$method\"" } foreach {flag cmd component} $Snit_typemethodInfo($method) break if {$flag} { return -code error "Unknown typemethod \"$method\"" } if {$component != ""} { return -code error "Delegated typemethod \"$method\"" } set map [list %m $method %j [join $method _] %t $type] set theproc [lindex [string map $map $cmd] 0] return [::info default $theproc $aname def] } # Returns a list of the type's instances whose names match # a pattern. # # type A Snit type # pattern Optional. The glob pattern to match # Defaults to * # # REQUIRE: type is fully qualified. proc ::snit::RT.typemethod.info.instances {type {pattern *}} { set result {} foreach selfns [namespace children $type "${type}::Snit_inst*"] { upvar ${selfns}::Snit_instance instance if {[string match $pattern $instance]} { lappend result $instance } } return $result } #----------------------------------------------------------------------- # Instance Introspection # Implements the standard "info" method. # # type The snit type # selfns The instance's instance namespace # win The instance's original name # self The instance's current name # command The info subcommand # args All other arguments. proc ::snit::RT.method.info {type selfns win self command args} { switch -exact $command { args - body - default - type - vars - options - methods - typevars - typemethods { set errflag [catch { uplevel 1 [linsert $args 0 ::snit::RT.method.info.$command \ $type $selfns $win $self] } result] if {$errflag} { global errorInfo return -code error -errorinfo $errorInfo $result } else { return $result } } default { # error "\"$self info $command\" is not defined" return -code error "\"$self info $command\" is not defined" } } } # $self info type # # Returns the instance's type proc ::snit::RT.method.info.type {type selfns win self} { return $type } # $self info typevars # # Returns the instance's type's typevariables proc ::snit::RT.method.info.typevars {type selfns win self {pattern *}} { return [RT.typemethod.info.typevars $type $pattern] } # $self info typemethods # # Returns the instance's type's typemethods proc ::snit::RT.method.info.typemethods {type selfns win self {pattern *}} { return [RT.typemethod.info.typemethods $type $pattern] } # Returns a list of the instance's methods whose names match a # pattern. If "delegate method *" is used, the list may # not be complete. # # type A Snit type # selfns The instance namespace # win The original instance name # self The current instance name # pattern Optional. The glob pattern to match. Defaults # to *. proc ::snit::RT.method.info.methods {type selfns win self {pattern *}} { variable ${type}::Snit_methodInfo variable ${selfns}::Snit_methodCache # FIRST, get the explicit names, skipping prefixes. set result {} foreach name [array names Snit_methodInfo $pattern] { if {[lindex $Snit_methodInfo($name) 0] != 1} { lappend result $name } } # NEXT, add any from the cache that aren't explicit. if {[info exists Snit_methodInfo(*)]} { # First, remove "*" from the list. set ndx [lsearch -exact $result "*"] if {$ndx != -1} { set result [lreplace $result $ndx $ndx] } foreach name [array names Snit_methodCache $pattern] { if {[lsearch -exact $result $name] == -1} { lappend result $name } } } return $result } # $self info args # # Returns a method's list of arguments. does not work for delegated # methods, nor for the internal dispatch methods of multi-word # methods. proc ::snit::RT.method.info.args {type selfns win self method} { upvar ${type}::Snit_methodInfo Snit_methodInfo # Snit_methodInfo: method -> list (flag cmd component) # flag : 1 -> internal dispatcher for multi-word method. # 0 -> regular method # # cmd : template mapping from method to command prefix, may # contain placeholders for various pieces of information. # # component : is empty for normal methods. #parray Snit_methodInfo if {![info exists Snit_methodInfo($method)]} { return -code error "Unknown method \"$method\"" } foreach {flag cmd component} $Snit_methodInfo($method) break if {$flag} { return -code error "Unknown method \"$method\"" } if {$component != ""} { return -code error "Delegated method \"$method\"" } set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self] set theproc [lindex [string map $map $cmd] 0] return [lrange [::info args $theproc] 4 end] } # $self info body # # Returns a method's body. does not work for delegated # methods, nor for the internal dispatch methods of multi-word # methods. proc ::snit::RT.method.info.body {type selfns win self method} { upvar ${type}::Snit_methodInfo Snit_methodInfo # Snit_methodInfo: method -> list (flag cmd component) # flag : 1 -> internal dispatcher for multi-word method. # 0 -> regular method # # cmd : template mapping from method to command prefix, may # contain placeholders for various pieces of information. # # component : is empty for normal methods. #parray Snit_methodInfo if {![info exists Snit_methodInfo($method)]} { return -code error "Unknown method \"$method\"" } foreach {flag cmd component} $Snit_methodInfo($method) break if {$flag} { return -code error "Unknown method \"$method\"" } if {$component != ""} { return -code error "Delegated method \"$method\"" } set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self] set theproc [lindex [string map $map $cmd] 0] return [RT.body [::info body $theproc]] } # $self info default # # Returns a method's list of arguments. does not work for delegated # methods, nor for the internal dispatch methods of multi-word # methods. proc ::snit::RT.method.info.default {type selfns win self method aname dvar} { upvar 1 $dvar def upvar ${type}::Snit_methodInfo Snit_methodInfo # Snit_methodInfo: method -> list (flag cmd component) # flag : 1 -> internal dispatcher for multi-word method. # 0 -> regular method # # cmd : template mapping from method to command prefix, may # contain placeholders for various pieces of information. # # component : is empty for normal methods. if {![info exists Snit_methodInfo($method)]} { return -code error "Unknown method \"$method\"" } foreach {flag cmd component} $Snit_methodInfo($method) break if {$flag} { return -code error "Unknown method \"$method\"" } if {$component != ""} { return -code error "Delegated method \"$method\"" } set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self] set theproc [lindex [string map $map $cmd] 0] return [::info default $theproc $aname def] } # $self info vars # # Returns the instance's instance variables proc ::snit::RT.method.info.vars {type selfns win self {pattern *}} { set result {} foreach name [info vars "${selfns}::$pattern"] { set tail [namespace tail $name] if {![string match "Snit_*" $tail]} { lappend result $name } } return $result } # $self info options # # Returns a list of the names of the instance's options proc ::snit::RT.method.info.options {type selfns win self {pattern *}} { variable ${type}::Snit_optionInfo # First, get the local and explicitly delegated options set result [concat $Snit_optionInfo(local) $Snit_optionInfo(delegated)] # If "configure" works as for Tk widgets, add the resulting # options to the list. Skip excepted options if {"" != $Snit_optionInfo(starcomp)} { upvar ${selfns}::Snit_components Snit_components set logicalName $Snit_optionInfo(starcomp) set comp $Snit_components($logicalName) if {![catch {$comp configure} records]} { foreach record $records { set opt [lindex $record 0] if {[lsearch -exact $result $opt] == -1 && [lsearch -exact $Snit_optionInfo(except) $opt] == -1} { lappend result $opt } } } } # Next, apply the pattern set names {} foreach name $result { if {[string match $pattern $name]} { lappend names $name } } return $names } proc ::snit::RT.body {body} { regsub -all ".*# END snit method prolog\n" $body {} body return $body } tcltk2/inst/tklibs/snit2.3.4/snit.test0000644000176200001440000062467215017041713017162 0ustar liggesusers# -*- tcl -*- #--------------------------------------------------------------------- # TITLE: # snit.test # # AUTHOR: # Will Duquette # # DESCRIPTION: # Test cases for snit.tcl. Uses the ::tcltest:: harness. # # If Tcl is 8.5, Snit 2.0 is loaded. # If Tcl is 8.4, Snit 1.2 is loaded. # If Tcl is 8.3, Snit 1.2 is loaded. (Kenneth Green's backport). # # Tests back-ported to Tcl 8.3 for snit 1.2 backport by kmg # Backport of test made general by Andreas Kupries. # # The tests assume tcltest 2.2 #----------------------------------------------------------------------- # Back-port to Tcl8.3 by Kenneth Green (kmg) # # Global changes: # " eq " => "string equal" # " ne " -> "!string equal" #----------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 2.2 #--------------------------------------------------------------------- # Set up a number of constraints. This also determines which # implementation of snit is loaded and tested. # WHD: Work around bugs in 8.5a3 tcltest::testConstraint bug8.5a3 [expr {![string equal [info patchlevel] "8.5a3"]}] # Marks tests which are only for Tk. tcltest::testConstraint tk [info exists tk_version] # If Tk is available, require BWidget tcltest::testConstraint bwidget [expr { [tcltest::testConstraint tk] && ![catch {package require BWidget}] }] # Determine which Snit version to load. If Tcl 8.5, use 2.x. set snitVersion 2 set snitFile snit2.tcl # For Snit 1 use # set snitVersion 1 # set snitFile snit.tcl # Marks tests which are only for Snit 1 tcltest::testConstraint snit1 [expr {$snitVersion == 1}] # Marks tests which are only for Snit 2 tcltest::testConstraint snit2 [expr {$snitVersion == 2}] if {[package vsatisfies [package provide Tcl] 8.6 9]} { # 8.6- proc expect {six default} { return $six } } else { # 8.5 proc expect {six default} { return $default } } #--------------------------------------------------------------------- # Load the snit package. testing { useLocal $snitFile snit } #--------------------------------------------------------------------- namespace import ::snit::* # Set up for Tk tests: Repeat background errors proc bgerror {msg} { global errorInfo set ::bideError $msg set ::bideErrorInfo $errorInfo } # Set up for Tk tests: enter the event loop long enough to catch # any bgerrors. proc tkbide {{msg "tkbide"} {msec 500}} { set ::bideVar 0 set ::bideError "" set ::bideErrorInfo "" # It looks like update idletasks does the job. if {0} { after $msec {set ::bideVar 1} tkwait variable ::bideVar } update idletasks if {"" != $::bideError} { error "$msg: $::bideError" $::bideErrorInfo } } # cleanup type proc cleanupType {name} { if {[namespace exists $name]} { if {[catch {$name destroy} result]} { global errorInfo puts $errorInfo error "Could not cleanup $name!" } } tkbide "cleanupType $name" } # cleanup before each test proc cleanup {} { global errorInfo cleanupType ::dog cleanupType ::cat cleanupType ::mylabel cleanupType ::myframe cleanupType ::foo cleanupType ::bar cleanupType ::tail cleanupType ::papers cleanupType ::animal cleanupType ::confused-dog catch {option clear} if {![string equal [info commands "spot"] ""]} { puts "spot not erased!" error "spot not erased!" } if {![string equal [info commands "fido"] ""]} { puts "fido not erased!" error "fido not erased!" } } # catch error code and error proc codecatch {command} { if {![catch {uplevel 1 $command} result]} { error "expected error, got OK" } return "$::errorCode $result" } #----------------------------------------------------------------------- # Internals: tests for Snit utility functions test Expand-1.1 {template, no arguments} -body { snit::Expand "My %TEMPLATE%" } -result {My %TEMPLATE%} test Expand-1.2 {template, no matching arguments} -body { snit::Expand "My %TEMPLATE%" %FOO% foo } -result {My %TEMPLATE%} test Expand-1.3 {template with matching arguments} -body { snit::Expand "%FOO% %BAR% %FOO%" %FOO% bar %BAR% foo } -result {bar foo bar} test Expand-1.4 {template with odd number of arguments} -body { snit::Expand "%FOO% %BAR% %FOO%" %FOO% } -result {char map list unbalanced} -returnCodes error test Mappend-1.1 {template, no arguments} -body { set text "Prefix: " snit::Mappend text "My %TEMPLATE%" } -cleanup { unset text } -result {Prefix: My %TEMPLATE%} test Mappend-1.2 {template, no matching arguments} -body { set text "Prefix: " snit::Mappend text "My %TEMPLATE%" %FOO% foo } -cleanup { unset text } -result {Prefix: My %TEMPLATE%} test Mappend-1.3 {template with matching arguments} -body { set text "Prefix: " snit::Mappend text "%FOO% %BAR% %FOO%" %FOO% bar %BAR% foo } -cleanup { unset text } -result {Prefix: bar foo bar} test Mappend-1.4 {template with odd number of arguments} -body { set text "Prefix: " snit::Mappend text "%FOO% %BAR% %FOO%" %FOO% } -cleanup { unset text } -returnCodes error -result {char map list unbalanced} test RT.UniqueName-1.1 {no name collision} -body { set counter 0 # Standard qualified type name. set n1 [snit::RT.UniqueName counter ::mytype ::my::%AUTO%] # Standard qualified widget name. set n2 [snit::RT.UniqueName counter ::mytype .my.%AUTO%] list $n1 $n2 } -result {::my::mytype1 .my.mytype2} -cleanup { unset counter n1 n2 } test RT.UniqueName-1.2 {name collision} -body { set counter 0 # Create the first two equivalent procs. proc ::mytype1 {} {} proc ::mytype2 {} {} # Create a new name; it should skip to 3. snit::RT.UniqueName counter ::mytype ::%AUTO% } -cleanup { unset counter rename ::mytype1 "" rename ::mytype2 "" } -result {::mytype3} test RT.UniqueName-1.3 {nested type name} -body { set counter 0 snit::RT.UniqueName counter ::thisis::yourtype ::your::%AUTO% } -cleanup { unset counter } -result {::your::yourtype1} test RT.UniqueInstanceNamespace-1.1 {no name collision} -setup { namespace eval ::mytype:: {} } -body { set counter 0 snit::RT.UniqueInstanceNamespace counter ::mytype } -cleanup { unset counter namespace delete ::mytype:: } -result {::mytype::Snit_inst1} test RT.UniqueInstanceNamespace-1.2 {name collision} -setup { namespace eval ::mytype:: {} namespace eval ::mytype::Snit_inst1:: {} namespace eval ::mytype::Snit_inst2:: {} } -body { set counter 0 # Should skip to 3. snit::RT.UniqueInstanceNamespace counter ::mytype } -cleanup { unset counter namespace delete ::mytype:: } -result {::mytype::Snit_inst3} test Contains-1.1 {contains element} -constraints { snit1 } -setup { set mylist {foo bar baz} } -body { snit::Contains baz $mylist } -cleanup { unset mylist } -result {1} test Contains-1.2 {does not contain element} -constraints { snit1 } -setup { set mylist {foo bar baz} } -body { snit::Contains quux $mylist } -cleanup { unset mylist } -result {0} #----------------------------------------------------------------------- # type compilation # snit::compile returns two values, the qualified type name # and the script to execute to define the type. This section # only checks the length of the list and the type name; # the content of the script is validated by the remainder # of this test suite. test compile-1.1 {compile returns qualified type} -body { set compResult [compile type dog { }] list [llength $compResult] [lindex $compResult 0] } -result {2 ::dog} #----------------------------------------------------------------------- # type destruction test typedestruction-1.1 {type command is deleted} -body { type dog { } dog destroy info command ::dog } -result {} test typedestruction-1.2 {instance commands are deleted} -body { type dog { } dog create spot dog destroy info command ::spot } -result {} test typedestruction-1.3 {type namespace is deleted} -body { type dog { } dog destroy namespace exists ::dog } -result {0} test typedestruction-1.4 {type proc is destroyed on error} -body { catch {type dog { error "Error creating dog" }} result list [namespace exists ::dog] [info commands ::dog] } -result {0 {}} test typedestruction-1.5 {unrelated namespaces are deleted, bug 2898640} -body { type dog {} namespace eval dog::unrelated {} dog destroy } -result {} #----------------------------------------------------------------------- # type and typemethods test type-1.1 {type names get qualified} -body { type dog {} } -cleanup { dog destroy } -result {::dog} test type-1.2 {typemethods can be defined} -body { type dog { typemethod foo {a b} { return [list $a $b] } } dog foo 1 2 } -cleanup { dog destroy } -result {1 2} test type-1.3 {upvar works in typemethods} -body { type dog { typemethod goodname {varname} { upvar $varname myvar set myvar spot } } set thename fido dog goodname thename set thename } -cleanup { dog destroy unset thename } -result {spot} test type-1.4 {typemethod args can't include type} -body { type dog { typemethod foo {a type b} { } } } -returnCodes error -result {typemethod foo's arglist may not contain "type" explicitly} test type-1.5 {typemethod args can't include self} -body { type dog { typemethod foo {a self b} { } } } -returnCodes error -result {typemethod foo's arglist may not contain "self" explicitly} test type-1.6 {typemethod args can span multiple lines} -body { # This case caused an error at definition time in 0.9 because the # arguments were included in a comment in the compile script, and # the subsequent lines weren't commented. type dog { typemethod foo { a b } { } } } -cleanup { dog destroy } -result {::dog} #----------------------------------------------------------------------- # typeconstructor test typeconstructor-1.1 {a typeconstructor can be defined} -body { type dog { typevariable a typeconstructor { set a 1 } typemethod aget {} { return $a } } dog aget } -cleanup { dog destroy } -result {1} test typeconstructor-1.2 {only one typeconstructor can be defined} -body { type dog { typevariable a typeconstructor { set a 1 } typeconstructor { set a 2 } } } -returnCodes error -result {too many typeconstructors} test typeconstructor-1.3 {type proc is destroyed on error} -body { catch { type dog { typeconstructor { error "Error creating dog" } } } result list [namespace exists ::dog] [info commands ::dog] } -result {0 {}} #----------------------------------------------------------------------- # Type components test typecomponent-1.1 {typecomponent defines typevariable} -body { type dog { typecomponent mycomp typemethod test {} { return $mycomp } } dog test } -cleanup { dog destroy } -result {} test typecomponent-1.2 {typecomponent trace executes} -body { type dog { typecomponent mycomp typemethod test {} { typevariable Snit_typecomponents set mycomp foo return $Snit_typecomponents(mycomp) } } dog test } -cleanup { dog destroy } -result {foo} test typecomponent-1.3 {typecomponent -public works} -body { type dog { typecomponent mycomp -public string typeconstructor { set mycomp string } } dog string length foo } -cleanup { dog destroy } -result {3} test typecomponent-1.4 {typecomponent -inherit yes} -body { type dog { typecomponent mycomp -inherit yes typeconstructor { set mycomp string } } dog length foo } -cleanup { dog destroy } -result {3} #----------------------------------------------------------------------- # hierarchical type methods test htypemethod-1.1 {hierarchical method, two tokens} -body { type dog { typemethod {wag tail} {} { return "wags tail" } } dog wag tail } -cleanup { dog destroy } -result {wags tail} test htypemethod-1.2 {hierarchical method, three tokens} -body { type dog { typemethod {wag tail proudly} {} { return "wags tail proudly" } } dog wag tail proudly } -cleanup { dog destroy } -result {wags tail proudly} test htypemethod-1.3 {hierarchical method, four tokens} -body { type dog { typemethod {wag tail really high} {} { return "wags tail really high" } } dog wag tail really high } -cleanup { dog destroy } -result {wags tail really high} test htypemethod-1.4 {redefinition is OK} -body { type dog { typemethod {wag tail} {} { return "wags tail" } typemethod {wag tail} {} { return "wags tail briskly" } } dog wag tail } -cleanup { dog destroy } -result {wags tail briskly} # Case 1 test htypemethod-1.5 {proper error on missing submethod} -constraints { snit1 } -body { cleanup type dog { typemethod {wag tail} {} { } } dog wag } -returnCodes { error } -cleanup { dog destroy } -result {wrong number args: should be "::dog wag method args"} # Case 2 test htypemethod-1.6 {proper error on missing submethod} -constraints { snit2 } -body { cleanup type dog { typemethod {wag tail} {} { } } dog wag } -returnCodes { error } -cleanup { dog destroy } -result [expect \ {wrong # args: should be "dog wag subcommand ?arg ...?"} \ {wrong # args: should be "dog wag subcommand ?argument ...?"}] # Case 1 test htypemethod-1.7 {proper error on bogus submethod} -constraints { snit1 } -body { cleanup type dog { typemethod {wag tail} {} { } } dog wag ears } -returnCodes { error } -cleanup { dog destroy } -result {"::dog wag ears" is not defined} # Case 2 test htypemethod-1.8 {proper error on bogus submethod} -constraints { snit2 } -body { cleanup type dog { typemethod {wag tail} {} { } } dog wag ears } -returnCodes { error } -cleanup { dog destroy } -result {unknown subcommand "ears": namespace ::dog does not export any commands} test htypemethod-2.1 {prefix/method collision, level 1, order 1} -body { type dog { typemethod wag {} {} typemethod {wag tail} {} {} } } -returnCodes { error } -result {Error in "typemethod {wag tail}...", "wag" has no submethods.} test htypemethod-2.2 {prefix/method collision, level 1, order 2} -body { type dog { typemethod {wag tail} {} {} typemethod wag {} {} } } -returnCodes { error } -result {Error in "typemethod wag...", "wag" has submethods.} test htypemethod-2.3 {prefix/method collision, level 2, order 1} -body { type dog { typemethod {wag tail} {} {} typemethod {wag tail proudly} {} {} } } -returnCodes { error } -result {Error in "typemethod {wag tail proudly}...", "wag tail" has no submethods.} test htypemethod-2.4 {prefix/method collision, level 2, order 2} -body { type dog { typemethod {wag tail proudly} {} {} typemethod {wag tail} {} {} } } -returnCodes { error } -result {Error in "typemethod {wag tail}...", "wag tail" has submethods.} #----------------------------------------------------------------------- # Typemethod delegation test dtypemethod-1.1 {delegate typemethod to non-existent component} -body { set result "" type dog { delegate typemethod foo to bar } dog foo } -returnCodes { error } -result {::dog delegates typemethod "foo" to undefined typecomponent "bar"} test dtypemethod-1.2 {delegating to existing typecomponent} -body { type dog { delegate typemethod length to string typeconstructor { set string string } } dog length foo } -cleanup { dog destroy } -result {3} # Case 1 test dtypemethod-1.3 {delegating to existing typecomponent with error} -constraints { snit1 } -body { type dog { delegate typemethod length to string typeconstructor { set string string } } dog length foo bar } -returnCodes { error } -result {wrong # args: should be "string length string"} # Case 2 test dtypemethod-1.4 {delegating to existing typecomponent with error} -constraints { snit2 } -body { type dog { delegate typemethod length to string typeconstructor { set string string } } dog length foo bar } -returnCodes { error } -result {wrong # args: should be "dog length string"} test dtypemethod-1.5 {delegating unknown typemethods to existing typecomponent} -body { type dog { delegate typemethod * to string typeconstructor { set string string } } dog length foo } -cleanup { dog destroy } -result {3} if {[package vsatisfies [package provide Tcl] 9]} { set stringErr1 {bad option "foo": must be cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart} set stringErr2 {unknown or ambiguous subcommand "foo": must be cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart} } elseif {[package vsatisfies [package provide Tcl] 8.6]} { set stringErr1 {bad option "foo": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart} set stringErr2 {unknown or ambiguous subcommand "foo": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart} } else { set stringErr1 {bad option "foo": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart} set stringErr2 {unknown or ambiguous subcommand "foo": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart} } # Case 1 test dtypemethod-1.6 {delegating unknown typemethod to existing typecomponent with error} -body { type dog { delegate typemethod * to stringhandler typeconstructor { set stringhandler string } } dog foo bar } -constraints { snit1 } -returnCodes { error } -result $stringErr1 test dtypemethod-1.6a.0 {delegating unknown typemethod to existing typecomponent with error} -body { type dog { delegate typemethod * to stringhandler typeconstructor { set stringhandler string } } dog foo bar } -constraints { snit2 tcl8.5only } -returnCodes { error } -result $stringErr2 test dtypemethod-1.6a.1 {delegating unknown typemethod to existing typecomponent with error} -body { type dog { delegate typemethod * to stringhandler typeconstructor { set stringhandler string } } dog foo bar } -constraints { snit2 tcl8.6plus } -returnCodes { error } -result $stringErr2 test dtypemethod-1.7 {can't delegate local typemethod: order 1} -body { type dog { typemethod foo {} {} delegate typemethod foo to bar } } -returnCodes { error } -result {Error in "delegate typemethod foo...", "foo" has been defined locally.} test dtypemethod-1.8 {can't delegate local typemethod: order 2} -body { type dog { delegate typemethod foo to bar typemethod foo {} {} } } -returnCodes { error } -result {Error in "typemethod foo...", "foo" has been delegated} # Case 1 test dtypemethod-1.9 {excepted methods are caught properly} -constraints { snit1 } -body { type dog { delegate typemethod * to string except {match index} typeconstructor { set string string } } catch {dog length foo} a catch {dog match foo} b catch {dog index foo} c list $a $b $c } -cleanup { dog destroy } -result {3 {"::dog match" is not defined} {"::dog index" is not defined}} # Case 2 test dtypemethod-1.10 {excepted methods are caught properly} -constraints { snit2 } -body { type dog { delegate typemethod * to string except {match index} typeconstructor { set string string } } catch {dog length foo} a catch {dog match foo} b catch {dog index foo} c list $a $b $c } -cleanup { dog destroy } -result {3 {unknown subcommand "match": must be length} {unknown subcommand "index": must be length}} test dtypemethod-1.11 {as clause can include arguments} -body { proc tail {a b} { return "<$a $b>" } type dog { delegate typemethod wag to tail as {wag briskly} typeconstructor { set tail tail } } dog wag } -cleanup { dog destroy rename tail "" } -result {} test dtypemethod-2.1 {'using "%c %m"' gets normal behavior} -body { type dog { delegate typemethod length to string using {%c %m} typeconstructor { set string string } } dog length foo } -cleanup { dog destroy } -result {3} test dtypemethod-2.2 {All relevant 'using' conversions are converted} -body { proc echo {args} { return $args } type dog { delegate typemethod {tail wag} using {echo %% %t %M %m %j %n %w %s %c} } dog tail wag } -cleanup { dog destroy rename echo "" } -result {% ::dog {tail wag} wag tail_wag %n %w %s %c} test dtypemethod-2.3 {"%%" is handled properly} -body { proc echo {args} { join $args "|" } type dog { delegate typemethod wag using {echo %%m %%%m} } dog wag } -cleanup { dog destroy rename echo "" } -result {%m|%wag} test dtypemethod-2.4 {Method "*" and "using"} -body { proc echo {args} { join $args "|" } type dog { delegate typemethod * using {echo %m} } list [dog wag] [dog bark loudly] } -cleanup { dog destroy rename echo "" } -result {wag bark|loudly} test dtypemethod-3.1 {typecomponent names can be changed dynamically} -body { proc echo {args} { join $args "|" } type dog { delegate typemethod length to mycomp typeconstructor { set mycomp string } typemethod switchit {} { set mycomp echo } } set a [dog length foo] dog switchit set b [dog length foo] list $a $b } -cleanup { dog destroy rename echo "" } -result {3 length|foo} test dtypemethod-4.1 {hierarchical typemethod, two tokens} -body { type tail { method wag {} {return "wags tail"} } type dog { typeconstructor { set tail [tail %AUTO%] } delegate typemethod {wag tail} to tail as wag } dog wag tail } -cleanup { dog destroy tail destroy } -result {wags tail} test dtypemethod-4.2 {hierarchical typemethod, three tokens} -body { type tail { method wag {} {return "wags tail"} } type dog { typeconstructor { set tail [tail %AUTO%] } delegate typemethod {wag tail proudly} to tail as wag } dog wag tail proudly } -cleanup { dog destroy tail destroy } -result {wags tail} test dtypemethod-4.3 {hierarchical typemethod, four tokens} -body { type tail { method wag {} {return "wags tail"} } type dog { typeconstructor { set tail [tail %AUTO%] } delegate typemethod {wag tail really high} to tail as wag } dog wag tail really high } -cleanup { dog destroy tail destroy } -result {wags tail} test dtypemethod-4.4 {redefinition is OK} -body { type tail { method {wag tail} {} {return "wags tail"} method {wag briskly} {} {return "wags tail briskly"} } type dog { typeconstructor { set tail [tail %AUTO%] } delegate typemethod {wag tail} to tail as {wag tail} delegate typemethod {wag tail} to tail as {wag briskly} } dog wag tail } -cleanup { dog destroy tail destroy } -result {wags tail briskly} test dtypemethod-4.5 {last token is used by default} -body { type tail { method wag {} {return "wags tail"} } type dog { typeconstructor { set tail [tail %AUTO%] } delegate typemethod {tail wag} to tail } dog tail wag } -cleanup { dog destroy tail destroy } -result {wags tail} test dtypemethod-4.6 {last token can be *} -body { type tail { method wag {} {return "wags"} method droop {} {return "droops"} } type dog { typeconstructor { set tail [tail %AUTO%] } delegate typemethod {tail *} to tail } list [dog tail wag] [dog tail droop] } -cleanup { dog destroy tail destroy } -result {wags droops} # Case 2 test dtypemethod-4.7 {except with multiple tokens} -constraints { snit1 } -body { type tail { method wag {} {return "wags"} method droop {} {return "droops"} } type dog { typeconstructor { set tail [tail %AUTO%] } delegate typemethod {tail *} to tail except droop } catch {dog tail droop} result list [dog tail wag] $result } -cleanup { dog destroy tail destroy } -result {wags {"::dog tail droop" is not defined}} # Case 2 test dtypemethod-4.8 {except with multiple tokens} -constraints { snit2 } -body { type tail { method wag {} {return "wags"} method droop {} {return "droops"} } type dog { typeconstructor { set tail [tail %AUTO%] } delegate typemethod {tail *} to tail except droop } catch {dog tail droop} result list [dog tail wag] $result } -cleanup { dog destroy tail destroy } -result {wags {unknown subcommand "droop": namespace ::dog does not export any commands}} test dtypemethod-4.9 {"*" in the wrong spot} -body { type dog { delegate typemethod {tail * wag} to tail } } -returnCodes { error } -result {Error in "delegate typemethod {tail * wag}...", "*" must be the last token.} test dtypemethod-5.1 {prefix/typemethod collision} -body { type dog { delegate typemethod wag to tail delegate typemethod {wag tail} to tail as wag } } -returnCodes { error } -result {Error in "delegate typemethod {wag tail}...", "wag" has no submethods.} test dtypemethod-5.2 {prefix/typemethod collision} -body { type dog { delegate typemethod {wag tail} to tail as wag delegate typemethod wag to tail } } -returnCodes { error } -result {Error in "delegate typemethod wag...", "wag" has submethods.} test dtypemethod-5.3 {prefix/typemethod collision} -body { type dog { delegate typemethod {wag tail} to tail delegate typemethod {wag tail proudly} to tail as wag } } -returnCodes { error } -result {Error in "delegate typemethod {wag tail proudly}...", "wag tail" has no submethods.} test dtypemethod-5.4 {prefix/typemethod collision} -body { type dog { delegate typemethod {wag tail proudly} to tail as wag delegate typemethod {wag tail} to tail } } -returnCodes { error } -result {Error in "delegate typemethod {wag tail}...", "wag tail" has submethods.} #----------------------------------------------------------------------- # type creation test creation-1.1 {type instance names get qualified} -body { type dog { } dog create spot } -cleanup { dog destroy } -result {::spot} test creation-1.2 {type instance names can be generated} -body { type dog { } dog create my%AUTO% } -cleanup { dog destroy } -result {::mydog1} test creation-1.3 {"create" method is optional} -body { type dog { } dog fido } -cleanup { dog destroy } -result {::fido} test creation-1.4 {constructor arg can't be type} -body { type dog { constructor {type} { } } } -returnCodes { error } -result {constructor's arglist may not contain "type" explicitly} test creation-1.5 {constructor arg can't be self} -body { type dog { constructor {self} { } } } -returnCodes { error } -result {constructor's arglist may not contain "self" explicitly} test creation-1.6 {weird names are OK} -body { # I.e., names with non-identifier characters type confused-dog { method meow {} { return "$self meows." } } confused-dog spot spot meow } -cleanup { confused-dog destroy } -result {::spot meows.} # Case 1 test creation-1.7 {If -hasinstances yes, [$type] == [$type create %AUTO%]} -constraints { snit1 } -body { type dog { variable dummy } set mydog [dog] } -cleanup { $mydog destroy dog destroy } -result {::dog1} # Case 2 test creation-1.8 {If -hasinstances yes, [$type] == [$type create %AUTO%]} -constraints { snit2 } -body { type dog { # WHD: In Snit 1.0, this pragma was not needed. pragma -hastypemethods no variable dummy } set mydog [dog] } -cleanup { # [dog destroy] doesn't exist $mydog destroy namespace delete ::dog } -result {::dog1} # Case 1 test creation-1.9 {If -hasinstances no, [$type] != [$type create %AUTO%]} -constraints { snit1 } -body { type dog { pragma -hasinstances no } set mydog [dog] } -cleanup { dog destroy } -returnCodes { error } -result {wrong # args: should be "::dog method args"} # Case 2 test creation-1.10 {If -hasinstances no, [$type] != [$type create %AUTO%]} -constraints { snit2 } -body { type dog { pragma -hasinstances no } set mydog [dog] } -cleanup { dog destroy } -returnCodes { error } -result [expect \ {wrong # args: should be "dog subcommand ?arg ...?"} \ {wrong # args: should be "dog subcommand ?argument ...?"}] # Case 1 test creation-1.11 {If widget, [$type] != [$type create %AUTO%]} -constraints { snit1 tk } -body { widget dog { variable dummy } set mydog [dog] } -cleanup { dog destroy } -returnCodes { error } -result {wrong # args: should be "::dog method args"} # Case 2 test creation-1.12 {If widget, [$type] != [$type create %AUTO%]} -constraints { snit2 tk } -body { widget dog { variable dummy } set mydog [dog] } -cleanup { dog destroy } -returnCodes { error } -result [expect \ {wrong # args: should be "dog subcommand ?arg ...?"} \ {wrong # args: should be "dog subcommand ?argument ...?"}] test creation-1.13 {If -hastypemethods yes, [$type] == [$type create %AUTO%]} -constraints { snit1 } -body { type dog { variable dummy } set mydog [dog] } -cleanup { dog destroy } -result {::dog1} test creation-1.14 {If -hastypemethods yes, [$type] != [$type create %AUTO%]} -constraints { snit2 } -body { type dog { variable dummy } set mydog [dog] } -cleanup { dog destroy } -returnCodes { error } -result [expect \ {wrong # args: should be "dog subcommand ?arg ...?"} \ {wrong # args: should be "dog subcommand ?argument ...?"}] test creation-2.1 {Can't call "destroy" in constructor} -body { type dog { constructor {} { $self destroy } } dog spot } -cleanup { dog destroy } -returnCodes { error } -result {Error in constructor: Called 'destroy' method in constructor} #----------------------------------------------------------------------- # procs test proc-1.1 {proc args can span multiple lines} -body { # This case caused an error at definition time in 0.9 because the # arguments were included in a comment in the compile script, and # the subsequent lines weren't commented. type dog { proc foo { a b } { } } } -cleanup { dog destroy } -result {::dog} #----------------------------------------------------------------------- # methods test method-1.1 {methods get called} -body { type dog { method bark {} { return "$self barks" } } dog create spot spot bark } -cleanup { dog destroy } -result {::spot barks} test method-1.2 {methods can call other methods} -body { type dog { method bark {} { return "$self barks." } method chase {quarry} { return "$self chases $quarry; [$self bark]" } } dog create spot spot chase cat } -cleanup { dog destroy } -result {::spot chases cat; ::spot barks.} test method-1.3 {instances can call one another} -body { type dog { method bark {} { return "$self barks." } method chase {quarry} { return "$self chases $quarry; [$quarry bark] [$self bark]" } } dog create spot dog create fido spot chase ::fido } -cleanup { dog destroy } -result {::spot chases ::fido; ::fido barks. ::spot barks.} test method-1.4 {upvar works in methods} -body { type dog { method goodname {varname} { upvar $varname myvar set myvar spot } } dog create fido set thename fido fido goodname thename set thename } -cleanup { dog destroy } -result {spot} # Case 1 test method-1.5 {unknown methods get an error} -constraints { snit1 } -body { type dog { } dog create spot set result "" spot chase } -cleanup { dog destroy } -returnCodes { error } -result {"::spot chase" is not defined} # Case 2 test method-1.6 {unknown methods get an error} -constraints { snit2 } -body { type dog { } dog create spot set result "" spot chase } -cleanup { dog destroy } -returnCodes { error } -result {unknown subcommand "chase": namespace ::dog::Snit_inst1 does not export any commands} test method-1.7 {info type method returns the object's type} -body { type dog { } dog create spot spot info type } -cleanup { dog destroy } -result {::dog} test method-1.8 {instance method can call type method} -body { type dog { typemethod hello {} { return "Hello" } method helloworld {} { return "[$type hello], World!" } } dog create spot spot helloworld } -cleanup { dog destroy } -result {Hello, World!} test method-1.9 {type methods must be qualified} -body { type dog { typemethod hello {} { return "Hello" } method helloworld {} { return "[hello], World!" } } dog create spot spot helloworld } -cleanup { dog destroy } -returnCodes { error } -result {invalid command name "hello"} # Case 1 test method-1.10 {too few arguments} -constraints { snit1 } -body { type dog { method bark {volume} { } } dog create spot spot bark } -cleanup { dog destroy } -returnCodes { error } -result [tcltest::wrongNumArgs ::dog::Snit_methodbark {type selfns win self volume} 4] # Case 2 test method-1.11 {too few arguments} -constraints { snit2 } -body { type dog { method bark {volume} { } } dog create spot spot bark } -cleanup { dog destroy } -returnCodes { error } -result {wrong # args: should be "spot bark volume"} # Case 1 test method-1.12 {too many arguments} -constraints { snit1 } -body { type dog { method bark {volume} { } } dog create spot spot bark really loud } -returnCodes { error } -result [tcltest::tooManyArgs ::dog::Snit_methodbark {type selfns win self volume}] # Case 2 test method-1.13 {too many arguments} -constraints { snit2 } -body { type dog { method bark {volume} { } } dog create spot spot bark really loud } -cleanup { dog destroy } -returnCodes { error } -result {wrong # args: should be "spot bark volume"} test method-1.14 {method args can't include type} -body { type dog { method foo {a type b} { } } } -returnCodes { error } -result {method foo's arglist may not contain "type" explicitly} test method-1.15 {method args can't include self} -body { type dog { method foo {a self b} { } } } -returnCodes { error } -result {method foo's arglist may not contain "self" explicitly} test method-1.16 {method args can span multiple lines} -body { # This case caused an error at definition time in 0.9 because the # arguments were included in a comment in the compile script, and # the subsequent lines weren't commented. type dog { method foo { a b } { } } } -cleanup { dog destroy } -result {::dog} #----------------------------------------------------------------------- # hierarchical methods test hmethod-1.1 {hierarchical method, two tokens} -body { type dog { method {wag tail} {} { return "$self wags tail." } } dog spot spot wag tail } -cleanup { dog destroy } -result {::spot wags tail.} test hmethod-1.2 {hierarchical method, three tokens} -body { type dog { method {wag tail proudly} {} { return "$self wags tail proudly." } } dog spot spot wag tail proudly } -cleanup { dog destroy } -result {::spot wags tail proudly.} test hmethod-1.3 {hierarchical method, three tokens} -body { type dog { method {wag tail really high} {} { return "$self wags tail really high." } } dog spot spot wag tail really high } -cleanup { dog destroy } -result {::spot wags tail really high.} test hmethod-1.4 {redefinition is OK} -body { type dog { method {wag tail} {} { return "$self wags tail." } method {wag tail} {} { return "$self wags tail briskly." } } dog spot spot wag tail } -cleanup { dog destroy } -result {::spot wags tail briskly.} # Case 1 test hmethod-1.5 {proper error on missing submethod} -constraints { snit1 } -body { type dog { method {wag tail} {} { } } dog spot spot wag } -cleanup { dog destroy } -returnCodes { error } -result {wrong number args: should be "::spot wag method args"} # Case 2 test hmethod-1.6 {proper error on missing submethod} -constraints { snit2 } -body { type dog { method {wag tail} {} { } } dog spot spot wag } -cleanup { dog destroy } -returnCodes { error } -result [expect \ {wrong # args: should be "spot wag subcommand ?arg ...?"} \ {wrong # args: should be "spot wag subcommand ?argument ...?"}] test hmethod-1.7 {submethods called in proper objects} -body { # NOTE: This test was added in response to a bug report by # Anton Kovalenko. In Snit 2.0, submethod ensembles were # created in the type namespace. If a type defines a submethod # ensemble, then all objects of that type would end up sharing # a single ensemble. Ensembles are created lazily, so in this # test, the first call to "fido this tail wag" and "spot this tail wag" # will yield the correct result, but the second call to # "fido this tail wag" will yield the same as the call to # "spot this tail wag", because spot's submethod ensemble has # displaced fido's. Until the bug is fixed, that is. # # Fortunately, Anton provided the fix as well. type tail { option -manner method wag {} { return "wags tail $options(-manner)" } } type dog { delegate option -manner to tail delegate method {this tail wag} to tail constructor {args} { set tail [tail %AUTO%] $self configurelist $args } } dog fido -manner briskly dog spot -manner slowly list [fido this tail wag] [spot this tail wag] [fido this tail wag] } -cleanup { dog destroy tail destroy } -result {{wags tail briskly} {wags tail slowly} {wags tail briskly}} test hmethod-2.1 {prefix/method collision} -body { type dog { method wag {} {} method {wag tail} {} { return "$self wags tail." } } } -returnCodes { error } -result {Error in "method {wag tail}...", "wag" has no submethods.} test hmethod-2.2 {prefix/method collision} -body { type dog { method {wag tail} {} { return "$self wags tail." } method wag {} {} } } -returnCodes { error } -result {Error in "method wag...", "wag" has submethods.} test hmethod-2.3 {prefix/method collision} -body { type dog { method {wag tail} {} {} method {wag tail proudly} {} { return "$self wags tail." } } } -returnCodes { error } -result {Error in "method {wag tail proudly}...", "wag tail" has no submethods.} test hmethod-2.4 {prefix/method collision} -body { type dog { method {wag tail proudly} {} { return "$self wags tail." } method {wag tail} {} {} } } -returnCodes { error } -result {Error in "method {wag tail}...", "wag tail" has submethods.} #----------------------------------------------------------------------- # mymethod and renaming test rename-1.1 {mymethod uses name of instance name variable} -body { type dog { method mymethod {} { list [mymethod] [mymethod "A B"] [mymethod A B] } } dog fido fido mymethod } -cleanup { dog destroy } -result {{::snit::RT.CallInstance ::dog::Snit_inst1} {::snit::RT.CallInstance ::dog::Snit_inst1 {A B}} {::snit::RT.CallInstance ::dog::Snit_inst1 A B}} test rename-1.2 {instances can be renamed} -body { type dog { method names {} { list [mymethod] $selfns $win $self } } dog fido set a [fido names] rename fido spot set b [spot names] concat $a $b } -cleanup { dog destroy } -result {{::snit::RT.CallInstance ::dog::Snit_inst1} ::dog::Snit_inst1 ::fido ::fido {::snit::RT.CallInstance ::dog::Snit_inst1} ::dog::Snit_inst1 ::fido ::spot} test rename-1.3 {rename to "" deletes an instance} -constraints { bug8.5a3 } -body { type dog { } dog fido rename fido "" namespace children ::dog } -cleanup { dog destroy } -result {} test rename-1.4 {rename to "" deletes an instance even after a rename} -constraints { bug8.5a3 } -body { type dog { } dog fido rename fido spot rename spot "" namespace children ::dog } -cleanup { dog destroy } -result {} test rename-1.5 {creating an object twice destroys the first instance} -constraints { bug8.5a3 } -body { type dog { # Can't even test this normally. pragma -canreplace yes } dog fido set a [namespace children ::dog] dog fido set b [namespace children ::dog] fido destroy set c [namespace children ::dog] list $a $b $c } -cleanup { dog destroy } -result {::dog::Snit_inst1 ::dog::Snit_inst2 {}} #----------------------------------------------------------------------- # mymethod actually works test mymethod-1.1 {run mymethod handler} -body { type foo { option -command {} method runcmd {} { eval [linsert $options(-command) end $self snarf] return } } type bar { variable sub constructor {args} { set sub [foo fubar -command [mymethod Handler]] return } method Handler {args} { set ::RES $args } method test {} { $sub runcmd return } } set ::RES {} bar boogle boogle test set ::RES } -cleanup { bar destroy foo destroy } -result {::bar::fubar snarf} #----------------------------------------------------------------------- # myproc test myproc-1.1 {myproc qualifies proc names} -body { type dog { proc foo {} {} typemethod getit {} { return [myproc foo] } } dog getit } -cleanup { dog destroy } -result {::dog::foo} test myproc-1.2 {myproc adds arguments} -body { type dog { proc foo {} {} typemethod getit {} { return [myproc foo "a b"] } } dog getit } -cleanup { dog destroy } -result {::dog::foo {a b}} test myproc-1.3 {myproc adds arguments} -body { type dog { proc foo {} {} typemethod getit {} { return [myproc foo "a b" c d] } } dog getit } -cleanup { dog destroy } -result {::dog::foo {a b} c d} test myproc-1.4 {procs with selfns work} -body { type dog { variable datum foo method qualify {} { return [myproc getdatum $selfns] } proc getdatum {selfns} { return $datum } } dog create spot eval [spot qualify] } -cleanup { dog destroy } -result {foo} #----------------------------------------------------------------------- # mytypemethod test mytypemethod-1.1 {mytypemethod qualifies typemethods} -body { type dog { typemethod this {} {} typemethod a {} { return [mytypemethod this] } typemethod b {} { return [mytypemethod this x] } typemethod c {} { return [mytypemethod this "x y"] } typemethod d {} { return [mytypemethod this x y] } } list [dog a] [dog b] [dog c] [dog d] } -cleanup { dog destroy } -result {{::dog this} {::dog this x} {::dog this {x y}} {::dog this x y}} #----------------------------------------------------------------------- # typevariable test typevariable-1.1 {typevarname qualifies typevariables} -body { # Note: typevarname is DEPRECATED. Real code should use # mytypevar instead. type dog { method tvname {name} { typevarname $name } } dog create spot spot tvname myvar } -cleanup { dog destroy } -result {::dog::myvar} test typevariable-1.2 {undefined typevariables are OK} -body { type dog { method tset {value} { typevariable theValue set theValue $value } method tget {} { typevariable theValue return $theValue } } dog create spot dog create fido spot tset Howdy list [spot tget] [fido tget] [set ::dog::theValue] } -cleanup { dog destroy } -result {Howdy Howdy Howdy} test typevariable-1.3 {predefined typevariables are OK} -body { type dog { typevariable greeting Hello method tget {} { return $greeting } } dog create spot dog create fido list [spot tget] [fido tget] [set ::dog::greeting] } -cleanup { dog destroy } -result {Hello Hello Hello} test typevariable-1.4 {typevariables can be arrays} -body { type dog { typevariable greetings method fill {} { set greetings(a) Hi set greetings(b) Howdy } } dog create spot spot fill list $::dog::greetings(a) $::dog::greetings(b) } -cleanup { dog destroy } -result {Hi Howdy} test typevariable-1.5 {typevariables can used in typemethods} -body { type dog { typevariable greetings Howdy typemethod greet {} { return $greetings } } dog greet } -cleanup { dog destroy } -result {Howdy} test typevariable-1.6 {typevariables can used in procs} -body { type dog { typevariable greetings Howdy method greet {} { return [realGreet] } proc realGreet {} { return $greetings } } dog create spot spot greet } -cleanup { dog destroy } -result {Howdy} test typevariable-1.7 {mytypevar qualifies typevariables} -body { type dog { method tvname {name} { mytypevar $name } } dog create spot spot tvname myvar } -cleanup { dog destroy } -result {::dog::myvar} test typevariable-1.8 {typevariable with too many initializers throws an error} -body { type dog { typevariable color dark brown } } -returnCodes { error } -result {Error in "typevariable color...", too many initializers} test typevariable-1.9 {typevariable with too many initializers throws an error} -body { type dog { typevariable color -array dark brown } set result } -returnCodes { error } -result {Error in "typevariable color...", too many initializers} test typevariable-1.10 {typevariable can initialize array variables} -body { type dog { typevariable data -array { family jones color brown } typemethod getdata {item} { return $data($item) } } list [dog getdata family] [dog getdata color] } -cleanup { dog destroy } -result {jones brown} #----------------------------------------------------------------------- # instance variable test ivariable-1.1 {myvar qualifies instance variables} -body { type dog { method vname {name} { myvar $name } } dog create spot spot vname somevar } -cleanup { dog destroy } -result {::dog::Snit_inst1::somevar} test ivariable-1.2 {undefined instance variables are OK} -body { type dog { method setgreeting {value} { variable greeting set greeting $value } method getgreeting {} { variable greeting return $greeting } } set spot [dog create spot] spot setgreeting Hey dog create fido fido setgreeting Howdy list [spot getgreeting] [fido getgreeting] [set ::dog::Snit_inst1::greeting] } -cleanup { dog destroy } -result {Hey Howdy Hey} test ivariable-1.3 {instance variables are destroyed automatically} -body { type dog { constructor {args} { variable greeting set greeting Hi } } dog create spot set g1 $::dog::Snit_inst1::greeting spot destroy list $g1 [info exists ::dog::Snit_inst1::greeting] } -cleanup { dog destroy } -result {Hi 0} test ivariable-1.4 {defined instance variables need not be declared} -body { type dog { variable greetings method put {} { set greetings Howdy } method get {} { return $greetings } } dog create spot spot put spot get } -cleanup { dog destroy } -result {Howdy} test ivariable-1.5 {instance variables can be arrays} -body { type dog { variable greetings method fill {} { set greetings(a) Hi set greetings(b) Howdy } method vname {} { return [myvar greetings] } } dog create spot spot fill list [set [spot vname](a)] [set [spot vname](b)] } -cleanup { dog destroy } -result {Hi Howdy} test ivariable-1.6 {instance variables can be initialized in the definition} -body { type dog { variable greetings {Hi Howdy} variable empty {} method list {} { list $greetings $empty } } dog create spot spot list } -cleanup { dog destroy } -result {{Hi Howdy} {}} test ivariable-1.7 {variable is illegal when selfns is undefined} -body { type dog { method caller {} { callee } proc callee {} { variable foo } } dog create spot spot caller } -returnCodes { error } -cleanup { dog destroy } -result {can't read "selfns": no such variable} test ivariable-1.8 {myvar is illegal when selfns is undefined} -body { type dog { method caller {} { callee } proc callee {} { myvar foo } } dog create spot spot caller } -returnCodes { error } -cleanup { dog destroy } -result {can't read "selfns": no such variable} test ivariable-1.9 {procs which define selfns see instance variables} -body { type dog { variable greeting Howdy method caller {} { return [callee $selfns] } proc callee {selfns} { return $greeting } } dog create spot spot caller } -cleanup { dog destroy } -result {Howdy} test ivariable-1.10 {in methods, variable works with fully qualified names} -body { namespace eval ::somenamespace:: { set somevar somevalue } type dog { method get {} { variable ::somenamespace::somevar return $somevar } } dog create spot spot get } -cleanup { dog destroy } -result {somevalue} test ivariable-1.11 {variable with too many initializers throws an error} -body { type dog { variable color dark brown } } -returnCodes { error } -result {Error in "variable color...", too many initializers} test ivariable-1.12 {variable with too many initializers throws an error} -body { type dog { variable color -array dark brown } } -returnCodes { error } -result {Error in "variable color...", too many initializers} test ivariable-1.13 {variable can initialize array variables} -body { type dog { variable data -array { family jones color brown } method getdata {item} { return $data($item) } } dog spot list [spot getdata family] [spot getdata color] } -cleanup { dog destroy } -result {jones brown} #----------------------------------------------------------------------- # codename # # NOTE: codename is deprecated; myproc should be used instead. test codename-1.1 {codename qualifies procs} -body { type dog { method qualify {} { return [codename myproc] } proc myproc {} { } } dog create spot spot qualify } -cleanup { dog destroy } -result {::dog::myproc} test codename-1.2 {procs with selfns work} -body { type dog { variable datum foo method qualify {} { return [list [codename getdatum] $selfns] } proc getdatum {selfns} { return $datum } } dog create spot eval [spot qualify] } -cleanup { dog destroy } -result {foo} #----------------------------------------------------------------------- # Options test option-1.1 {options get default values} -body { type dog { option -color golden } dog create spot spot cget -color } -cleanup { dog destroy } -result {golden} test option-1.2 {options can be set} -body { type dog { option -color golden } dog create spot spot configure -color black spot cget -color } -cleanup { dog destroy } -result {black} test option-1.3 {multiple options can be set} -body { type dog { option -color golden option -akc 0 } dog create spot spot configure -color brown -akc 1 list [spot cget -color] [spot cget -akc] } -cleanup { dog destroy } -result {brown 1} test option-1.4 {options can be retrieved as instance variable} -body { type dog { option -color golden option -akc 0 method listopts {} { list $options(-color) $options(-akc) } } dog create spot spot configure -color black -akc 1 spot listopts } -cleanup { dog destroy } -result {black 1} test option-1.5 {options can be set as an instance variable} -body { type dog { option -color golden option -akc 0 method setopts {} { set options(-color) black set options(-akc) 1 } } dog create spot spot setopts list [spot cget -color] [spot cget -akc] } -cleanup { dog destroy } -result {black 1} test option-1.6 {options can be set at creation time} -body { type dog { option -color golden option -akc 0 } dog create spot -color white -akc 1 list [spot cget -color] [spot cget -akc] } -cleanup { dog destroy } -result {white 1} test option-1.7 {undefined option: cget} -body { type dog { option -color golden option -akc 0 } dog create spot spot cget -colour } -returnCodes { error } -cleanup { dog destroy } -result {unknown option "-colour"} test option-1.8 {undefined option: configure} -body { type dog { option -color golden option -akc 0 } dog create spot spot configure -colour blue } -returnCodes { error } -cleanup { dog destroy } -result {unknown option "-colour"} test option-1.9 {options default to ""} -body { type dog { option -color } dog create spot spot cget -color } -cleanup { dog destroy } -result {} test option-1.10 {spaces allowed in option defaults} -body { type dog { option -breed "golden retriever" } dog fido fido cget -breed } -cleanup { dog destroy } -result {golden retriever} test option-1.11 {brackets allowed in option defaults} -body { type dog { option -regexp {[a-z]+} } dog fido fido cget -regexp } -cleanup { dog destroy } -result {[a-z]+} test option-2.1 {configure returns info, local options only} -body { type dog { option -color black option -akc 1 } dog create spot spot configure -color red spot configure -akc 0 spot configure } -cleanup { dog destroy } -result {{-color color Color black red} {-akc akc Akc 1 0}} test option-2.2 {configure -opt returns info, local options only} -body { type dog { option -color black option -akc 1 } dog create spot spot configure -color red spot configure -color } -cleanup { dog destroy } -result {-color color Color black red} test option-2.3 {configure -opt returns info, explicit options} -body { type papers { option -akcflag 1 } type dog { option -color black delegate option -akc to papers as -akcflag constructor {args} { set papers [papers create $self.papers] } destructor { catch {$self.papers destroy} } } dog create spot spot configure -akc 0 spot configure -akc } -cleanup { dog destroy } -result {-akc akc Akc 1 0} test option-2.4 {configure -unknownopt} -body { type papers { option -akcflag 1 } type dog { option -color black delegate option -akc to papers as -akcflag constructor {args} { set papers [papers create $self.papers] } destructor { catch {$self.papers destroy} } } dog create spot spot configure -foo } -returnCodes { error } -cleanup { dog destroy papers destroy } -result {unknown option "-foo"} test option-2.5 {configure returns info, unknown options} -constraints { tk } -body { widgetadaptor myframe { option -foo a delegate option -width to hull delegate option * to hull constructor {args} { installhull [frame $self] } } myframe .frm set a [.frm configure -foo] set b [.frm configure -width] set c [.frm configure -height] destroy .frm tkbide list $a $b $c } -cleanup { myframe destroy } -result {{-foo foo Foo a a} {-width width Width 0 0} {-height height Height 0 0}} test option-2.6 {configure -opt unknown to implicit component} -constraints { tk } -body { widgetadaptor myframe { delegate option * to hull constructor {args} { installhull [frame $self] } } myframe .frm catch {.frm configure -quux} result destroy .frm tkbide set result } -cleanup { myframe destroy } -result {unknown option "-quux"} test option-3.1 {set option resource name explicitly} -body { type dog { option {-tailcolor tailColor} black } dog fido fido configure -tailcolor } -cleanup { dog destroy } -result {-tailcolor tailColor TailColor black black} test option-3.2 {set option class name explicitly} -body { type dog { option {-tailcolor tailcolor TailColor} black } dog fido fido configure -tailcolor } -cleanup { dog destroy } -result {-tailcolor tailcolor TailColor black black} test option-3.3 {delegated option's names come from owner} -body { type tail { option -color black } type dog { delegate option -tailcolor to tail as -color constructor {args} { set tail [tail fidotail] } } dog fido fido configure -tailcolor } -cleanup { dog destroy tail destroy } -result {-tailcolor tailcolor Tailcolor black black} test option-3.4 {delegated option's resource name set explicitly} -body { type tail { option -color black } type dog { delegate option {-tailcolor tailColor} to tail as -color constructor {args} { set tail [tail fidotail] } } dog fido fido configure -tailcolor } -cleanup { dog destroy tail destroy } -result {-tailcolor tailColor TailColor black black} test option-3.5 {delegated option's class name set explicitly} -body { type tail { option -color black } type dog { delegate option {-tailcolor tailcolor TailColor} to tail as -color constructor {args} { set tail [tail fidotail] } } dog fido fido configure -tailcolor } -cleanup { dog destroy tail destroy } -result {-tailcolor tailcolor TailColor black black} test option-3.6 {delegated option's default comes from component} -body { type tail { option -color black } type dog { delegate option -tailcolor to tail as -color constructor {args} { set tail [tail fidotail -color red] } } dog fido fido configure -tailcolor } -cleanup { dog destroy tail destroy } -result {-tailcolor tailcolor Tailcolor black red} test option-4.1 {local option name must begin with hyphen} -body { type dog { option nohyphen } } -returnCodes { error } -result {Error in "option nohyphen...", badly named option "nohyphen"} test option-4.2 {local option name must be lower case} -body { type dog { option -Upper } } -returnCodes { error } -result {Error in "option -Upper...", badly named option "-Upper"} test option-4.3 {local option name may not contain spaces} -body { type dog { option {"-with space"} } } -returnCodes { error } -result {Error in "option {"-with space"}...", badly named option "-with space"} test option-4.4 {delegated option name must begin with hyphen} -body { type dog { delegate option nohyphen to tail } } -returnCodes { error } -result {Error in "delegate option nohyphen...", badly named option "nohyphen"} test option-4.5 {delegated option name must be lower case} -body { type dog { delegate option -Upper to tail } } -returnCodes { error } -result {Error in "delegate option -Upper...", badly named option "-Upper"} test option-4.6 {delegated option name may not contain spaces} -body { type dog { delegate option {"-with space"} to tail } } -returnCodes { error } -result {Error in "delegate option {"-with space"}...", badly named option "-with space"} test option-5.1 {local widget options read from option database} -constraints { tk } -body { widget dog { option -foo a option -bar b typeconstructor { option add *Dog.bar bb } } dog .fido set a [.fido cget -foo] set b [.fido cget -bar] destroy .fido tkbide list $a $b } -cleanup { dog destroy } -result {a bb} test option-5.2 {local option database values available in constructor} -constraints { tk } -body { widget dog { option -bar b variable saveit typeconstructor { option add *Dog.bar bb } constructor {args} { set saveit $options(-bar) } method getit {} { return $saveit } } dog .fido set result [.fido getit] destroy .fido tkbide set result } -cleanup { dog destroy } -result {bb} test option-6.1 {if no options, no options variable} -body { type dog { variable dummy } dog spot spot info vars options } -cleanup { dog destroy } -result {} test option-6.2 {if no options, no options methods} -body { type dog { variable dummy } dog spot spot info methods c* } -cleanup { dog destroy } -result {} #----------------------------------------------------------------------- # onconfigure test onconfigure-1.1 {invalid onconfigure methods are caught} -body { type dog { onconfigure -color {value} { } } } -returnCodes { error } -result {onconfigure -color: option "-color" unknown} test onconfigure-1.2 {onconfigure methods take one argument} -body { type dog { option -color golden onconfigure -color {value badarg} { } } } -returnCodes { error } -result {onconfigure -color handler should have one argument, got "value badarg"} test onconfigure-1.3 {onconfigure methods work} -body { type dog { option -color golden onconfigure -color {value} { set options(-color) "*$value*" } } dog create spot spot configure -color brown spot cget -color } -cleanup { dog destroy } -result {*brown*} test onconfigure-1.4 {onconfigure arg can't be type} -body { type dog { option -color onconfigure -color {type} { } } } -returnCodes { error } -result {onconfigure -color's arglist may not contain "type" explicitly} test onconfigure-1.5 {onconfigure arg can't be self} -body { type dog { option -color onconfigure -color {self} { } } } -returnCodes { error } -result {onconfigure -color's arglist may not contain "self" explicitly} #----------------------------------------------------------------------- # oncget test oncget-1.1 {invalid oncget methods are caught} -body { type dog { oncget -color { } } } -returnCodes { error } -result {Error in "oncget -color...", option "-color" unknown} test oncget-1.2 {oncget methods work} -body { cleanup type dog { option -color golden oncget -color { return "*$options(-color)*" } } dog create spot spot configure -color brown spot cget -color } -cleanup { dog destroy } -result {*brown*} #----------------------------------------------------------------------- # constructor test constructor-1.1 {constructor can do things} -body { type dog { variable a variable b constructor {args} { set a 1 set b 2 } method foo {} { list $a $b } } dog create spot spot foo } -cleanup { dog destroy } -result {1 2} test constructor-1.2 {constructor with no configurelist ignores args} -body { type dog { constructor {args} { } option -color golden option -akc 0 } dog create spot -color white -akc 1 list [spot cget -color] [spot cget -akc] } -cleanup { dog destroy } -result {golden 0} test constructor-1.3 {constructor with configurelist gets args} -body { type dog { constructor {args} { $self configurelist $args } option -color golden option -akc 0 } dog create spot -color white -akc 1 list [spot cget -color] [spot cget -akc] } -cleanup { dog destroy } -result {white 1} test constructor-1.4 {constructor with specific args} -body { type dog { option -value "" constructor {a b args} { set options(-value) [list $a $b $args] } } dog spot retriever golden -akc 1 spot cget -value } -cleanup { dog destroy } -result {retriever golden {-akc 1}} test constructor-1.5 {constructor with list as one list arg} -body { type dog { option -value "" constructor {args} { set options(-value) $args } } dog spot {retriever golden} spot cget -value } -cleanup { dog destroy } -result {{retriever golden}} test constructor-1.6 {default constructor configures options} -body { type dog { option -color brown option -breed mutt } dog spot -color golden -breed retriever list [spot cget -color] [spot cget -breed] } -cleanup { dog destroy } -result {golden retriever} test constructor-1.7 {default constructor takes no args if no options} -body { type dog { variable color } dog spot -color golden } -returnCodes { error } -result "Error in constructor: [tcltest::tooManyArgs ::dog::Snit_constructor {type selfns win self}]" #----------------------------------------------------------------------- # destroy test destroy-1.1 {destroy cleans up the instance} -body { type dog { option -color golden } set a [namespace children ::dog::] dog create spot set b [namespace children ::dog::] spot destroy set c [namespace children ::dog::] list $a $b $c [info commands ::dog::spot] } -cleanup { dog destroy } -result {{} ::dog::Snit_inst1 {} {}} test destroy-1.2 {incomplete objects are destroyed} -body { array unset ::dog::snit_ivars type dog { option -color golden constructor {args} { $self configurelist $args if {"red" == [$self cget -color]} { error "No Red Dogs!" } } } catch {dog create spot -color red} result set names [array names ::dog::snit_ivars] list $result $names [info commands ::dog::spot] } -cleanup { dog destroy } -result {{Error in constructor: No Red Dogs!} {} {}} test destroy-1.3 {user-defined destructors are called} -body { type dog { typevariable flag "" constructor {args} { set flag "created $self" } destructor { set flag "destroyed $self" } typemethod getflag {} { return $flag } } dog create spot set a [dog getflag] spot destroy list $a [dog getflag] } -cleanup { dog destroy } -result {{created ::spot} {destroyed ::spot}} #----------------------------------------------------------------------- # delegate: general syntax tests test delegate-1.1 {can only delegate methods or options} -body { type dog { delegate foo bar to baz } } -returnCodes { error } -result {Error in "delegate foo bar...", "foo"?} test delegate-1.2 {"to" must appear in the right place} -body { type dog { delegate method foo from bar } } -returnCodes { error } -result {Error in "delegate method foo...", unknown delegation option "from"} test delegate-1.3 {"as" must have a target} -body { type dog { delegate method foo to bar as } } -returnCodes { error } -result {Error in "delegate method foo...", invalid syntax} test delegate-1.4 {"as" must have a single target} -body { type dog { delegate method foo to bar as baz quux } } -returnCodes { error } -result {Error in "delegate method foo...", unknown delegation option "quux"} test delegate-1.5 {"as" doesn't work with "*"} -body { type dog { delegate method * to hull as foo } } -returnCodes { error } -result {Error in "delegate method *...", cannot specify "as" with "*"} test delegate-1.6 {"except" must have a target} -body { type dog { delegate method * to bar except } } -returnCodes { error } -result {Error in "delegate method *...", invalid syntax} test delegate-1.7 {"except" must have a single target} -body { type dog { delegate method * to bar except baz quux } } -returnCodes { error } -result {Error in "delegate method *...", unknown delegation option "quux"} test delegate-1.8 {"except" works only with "*"} -body { type dog { delegate method foo to hull except bar } } -returnCodes { error } -result {Error in "delegate method foo...", can only specify "except" with "*"} test delegate-1.9 {only "as" or "except"} -body { type dog { delegate method foo to bar with quux } } -returnCodes { error } -result {Error in "delegate method foo...", unknown delegation option "with"} #----------------------------------------------------------------------- # delegated methods test dmethod-1.1 {delegate method to non-existent component} -body { type dog { delegate method foo to bar } dog create spot spot foo } -returnCodes { error } -cleanup { dog destroy } -result {::dog ::spot delegates method "foo" to undefined component "bar"} test dmethod-1.2 {delegating to existing component} -body { type dog { constructor {args} { set string string } delegate method length to string } dog create spot spot length foo } -cleanup { dog destroy } -result {3} # Case 1 test dmethod-1.3 {delegating to existing component with error} -constraints { snit1 } -body { type dog { constructor {args} { set string string } delegate method length to string } dog create spot spot length foo bar } -cleanup { dog destroy } -returnCodes { error } -result {wrong # args: should be "string length string"} # Case 2 test dmethod-1.4 {delegating to existing component with error} -constraints { snit2 } -body { type dog { constructor {args} { set string string } delegate method length to string } dog create spot spot length foo bar } -cleanup { dog destroy } -returnCodes { error } -result {wrong # args: should be "spot length string"} test dmethod-1.5 {delegating unknown methods to existing component} -body { type dog { constructor {args} { set string string } delegate method * to string } dog create spot spot length foo } -cleanup { dog destroy } -result {3} test dmethod-1.6 {delegating unknown method to existing component with error} -body { type dog { constructor {args} { set stringhandler string } delegate method * to stringhandler } dog create spot spot foo bar } -constraints { snit1 } -returnCodes { error } -cleanup { dog destroy } -result $stringErr1 test dmethod-1.6a.0 {delegating unknown method to existing component with error} -body { type dog { constructor {args} { set stringhandler string } delegate method * to stringhandler } dog create spot spot foo bar } -constraints { snit2 tcl8.5only } -returnCodes { error } -cleanup { dog destroy } -result $stringErr2 test dmethod-1.6a.1 {delegating unknown method to existing component with error} -body { type dog { constructor {args} { set stringhandler string } delegate method * to stringhandler } dog create spot spot foo bar } -constraints { snit2 tcl8.6plus } -returnCodes { error } -cleanup { dog destroy } -result $stringErr2 test dmethod-1.7 {can't delegate local method: order 1} -body { type cat { method foo {} {} delegate method foo to hull } } -returnCodes { error } -result {Error in "delegate method foo...", "foo" has been defined locally.} test dmethod-1.8 {can't delegate local method: order 2} -body { type cat { delegate method foo to hull method foo {} {} } } -returnCodes { error } -result {Error in "method foo...", "foo" has been delegated} # Case 1 test dmethod-1.9 {excepted methods are caught properly} -constraints { snit1 } -body { type tail { method wag {} {return "wagged"} method flaunt {} {return "flaunted"} method tuck {} {return "tuck"} } type cat { method meow {} {} delegate method * to tail except {wag tuck} constructor {args} { set tail [tail %AUTO%] } } cat fifi catch {fifi flaunt} a catch {fifi wag} b catch {fifi tuck} c list $a $b $c } -cleanup { cat destroy tail destroy } -result {flaunted {"::fifi wag" is not defined} {"::fifi tuck" is not defined}} # Case 2 test dmethod-1.10 {excepted methods are caught properly} -constraints { snit2 } -body { type tail { method wag {} {return "wagged"} method flaunt {} {return "flaunted"} method tuck {} {return "tuck"} } type cat { method meow {} {} delegate method * to tail except {wag tuck} constructor {args} { set tail [tail %AUTO%] } } cat fifi catch {fifi flaunt} a catch {fifi wag} b catch {fifi tuck} c list $a $b $c } -cleanup { cat destroy tail destroy } -result {flaunted {unknown subcommand "wag": must be flaunt} {unknown subcommand "tuck": must be flaunt}} test dmethod-1.11 {as clause can include arguments} -body { type tail { method wag {adverb} {return "wagged $adverb"} } type dog { delegate method wag to tail as {wag briskly} constructor {args} { set tail [tail %AUTO%] } } dog spot spot wag } -cleanup { dog destroy tail destroy } -result {wagged briskly} test dmethod-2.1 {'using "%c %m"' gets normal behavior} -body { type tail { method wag {adverb} {return "wagged $adverb"} } type dog { delegate method wag to tail using {%c %m} constructor {args} { set tail [tail %AUTO%] } } dog spot spot wag briskly } -cleanup { dog destroy tail destroy } -result {wagged briskly} test dmethod-2.2 {All 'using' conversions are converted} -body { proc echo {args} { return $args } type dog { delegate method {tail wag} using {echo %% %t %M %m %j %n %w %s %c} } dog spot spot tail wag } -cleanup { dog destroy rename echo "" } -result {% ::dog {tail wag} wag tail_wag ::dog::Snit_inst1 ::spot ::spot %c} test dmethod-2.3 {"%%" is handled properly} -body { proc echo {args} { join $args "|" } type dog { delegate method wag using {echo %%m %%%m} } dog spot spot wag } -cleanup { dog destroy rename echo "" } -result {%m|%wag} test dmethod-2.4 {Method "*" and "using"} -body { proc echo {args} { join $args "|" } type dog { delegate method * using {echo %m} } dog spot list [spot wag] [spot bark loudly] } -cleanup { dog destroy rename echo "" } -result {wag bark|loudly} test dmethod-3.1 {component names can be changed dynamically} -body { type tail1 { method wag {} {return "wagged"} } type tail2 { method wag {} {return "drooped"} } type dog { delegate method wag to tail constructor {args} { set tail [tail1 %AUTO%] } method switchit {} { set tail [tail2 %AUTO%] } } dog fido set a [fido wag] fido switchit set b [fido wag] list $a $b } -cleanup { dog destroy tail1 destroy tail2 destroy } -result {wagged drooped} test dmethod-4.1 {hierarchical method, two tokens} -body { type tail { method wag {} {return "wags tail"} } type dog { constructor {} { set tail [tail %AUTO%] } delegate method {wag tail} to tail as wag } dog spot spot wag tail } -cleanup { dog destroy tail destroy } -result {wags tail} test dmethod-4.2 {hierarchical method, three tokens} -body { type tail { method wag {} {return "wags tail"} } type dog { constructor {} { set tail [tail %AUTO%] } delegate method {wag tail proudly} to tail as wag } dog spot spot wag tail proudly } -cleanup { dog destroy tail destroy } -result {wags tail} test dmethod-4.3 {hierarchical method, three tokens} -body { type tail { method wag {} {return "wags tail"} } type dog { constructor {} { set tail [tail %AUTO%] } delegate method {wag tail really high} to tail as wag } dog spot spot wag tail really high } -cleanup { dog destroy tail destroy } -result {wags tail} test dmethod-4.4 {redefinition is OK} -body { type tail { method {wag tail} {} {return "wags tail"} method {wag briskly} {} {return "wags tail briskly"} } type dog { constructor {} { set tail [tail %AUTO%] } delegate method {wag tail} to tail as {wag tail} delegate method {wag tail} to tail as {wag briskly} } dog spot spot wag tail } -cleanup { dog destroy tail destroy } -result {wags tail briskly} test dmethod-4.5 {all tokens are used by default} -body { type tail { method wag {} {return "wags tail"} } type dog { constructor {} { set tail [tail %AUTO%] } delegate method {tail wag} to tail } dog spot spot tail wag } -cleanup { dog destroy tail destroy } -result {wags tail} test dmethod-4.6 {last token can be *} -body { type tail { method wag {} {return "wags"} method droop {} {return "droops"} } type dog { constructor {} { set tail [tail %AUTO%] } delegate method {tail *} to tail } dog spot list [spot tail wag] [spot tail droop] } -cleanup { dog destroy tail destroy } -result {wags droops} # Case 1 test dmethod-4.7 {except with multiple tokens} -constraints { snit1 } -body { type tail { method wag {} {return "wags"} method droop {} {return "droops"} } type dog { constructor {} { set tail [tail %AUTO%] } delegate method {tail *} to tail except droop } dog spot catch {spot tail droop} result list [spot tail wag] $result } -cleanup { dog destroy tail destroy } -result {wags {"::spot tail droop" is not defined}} # Case 2 test dmethod-4.8 {except with multiple tokens} -constraints { snit2 } -body { type tail { method wag {} {return "wags"} method droop {} {return "droops"} } type dog { constructor {} { set tail [tail %AUTO%] } delegate method {tail *} to tail except droop } dog spot catch {spot tail droop} result list [spot tail wag] $result } -cleanup { dog destroy tail destroy } -result {wags {unknown subcommand "droop": namespace ::dog::Snit_inst1 does not export any commands}} test dmethod-4.9 {"*" in the wrong spot} -body { type dog { delegate method {tail * wag} to tail } } -returnCodes { error } -result {Error in "delegate method {tail * wag}...", "*" must be the last token.} test dmethod-5.1 {prefix/method collision} -body { type dog { delegate method wag to tail delegate method {wag tail} to tail as wag } } -returnCodes { error } -result {Error in "delegate method {wag tail}...", "wag" has no submethods.} test dmethod-5.2 {prefix/method collision} -body { type dog { delegate method {wag tail} to tail as wag delegate method wag to tail } } -returnCodes { error } -result {Error in "delegate method wag...", "wag" has submethods.} test dmethod-5.3 {prefix/method collision} -body { type dog { delegate method {wag tail} to tail delegate method {wag tail proudly} to tail as wag } } -returnCodes { error } -result {Error in "delegate method {wag tail proudly}...", "wag tail" has no submethods.} test dmethod-5.4 {prefix/method collision} -body { type dog { delegate method {wag tail proudly} to tail as wag delegate method {wag tail} to tail } } -returnCodes { error } -result {Error in "delegate method {wag tail}...", "wag tail" has submethods.} #----------------------------------------------------------------------- # delegated options test doption-1.1 {delegate option to non-existent component} -body { type dog { delegate option -foo to bar } dog create spot spot cget -foo } -returnCodes { error } -cleanup { dog destroy } -result {component "bar" is undefined in ::dog ::spot} test doption-1.2 {delegating option to existing component: cget} -body { type cat { option -color "black" } cat create hershey type dog { constructor {args} { set catthing ::hershey } delegate option -color to catthing } dog create spot spot cget -color } -cleanup { dog destroy cat destroy } -result {black} test doption-1.3 {delegating option to existing component: configure} -body { type cat { option -color "black" } cat create hershey type dog { constructor {args} { set catthing ::hershey $self configurelist $args } delegate option -color to catthing } dog create spot -color blue list [spot cget -color] [hershey cget -color] } -cleanup { dog destroy cat destroy } -result {blue blue} test doption-1.4 {delegating unknown options to existing component} -body { type cat { option -color "black" } cat create hershey type dog { constructor {args} { set catthing ::hershey # Note: must do this after components are defined; this # may be a problem. $self configurelist $args } delegate option * to catthing } dog create spot -color blue list [spot cget -color] [hershey cget -color] } -cleanup { dog destroy cat destroy } -result {blue blue} test doption-1.5 {can't oncget for delegated option} -body { type dog { delegate option -color to catthing oncget -color { } } } -returnCodes { error } -result {Error in "oncget -color...", option "-color" is delegated} test doption-1.6 {can't onconfigure for delegated option} -body { type dog { delegate option -color to catthing onconfigure -color {value} { } } } -returnCodes { error } -result {onconfigure -color: option "-color" is delegated} test doption-1.7 {delegating unknown options to existing component: error} -body { type cat { option -color "black" } cat create hershey type dog { constructor {args} { set catthing ::hershey $self configurelist $args } delegate option * to catthing } dog create spot -colour blue } -returnCodes { error } -cleanup { dog destroy cat destroy } -result {Error in constructor: unknown option "-colour"} test doption-1.8 {can't delegate local option: order 1} -body { type cat { option -color "black" delegate option -color to hull } } -returnCodes { error } -result {Error in "delegate option -color...", "-color" has been defined locally} test doption-1.9 {can't delegate local option: order 2} -body { type cat { delegate option -color to hull option -color "black" } } -returnCodes { error } -result {Error in "option -color...", cannot define "-color" locally, it has been delegated} test doption-1.10 {excepted options are caught properly on cget} -body { type tail { option -a a option -b b option -c c } type cat { delegate option * to tail except {-b -c} constructor {args} { set tail [tail %AUTO%] } } cat fifi catch {fifi cget -a} a catch {fifi cget -b} b catch {fifi cget -c} c list $a $b $c } -cleanup { cat destroy tail destroy } -result {a {unknown option "-b"} {unknown option "-c"}} test doption-1.11 {excepted options are caught properly on configurelist} -body { type tail { option -a a option -b b option -c c } type cat { delegate option * to tail except {-b -c} constructor {args} { set tail [tail %AUTO%] } } cat fifi catch {fifi configurelist {-a 1}} a catch {fifi configurelist {-b 1}} b catch {fifi configurelist {-c 1}} c list $a $b $c } -cleanup { cat destroy tail destroy } -result {{} {unknown option "-b"} {unknown option "-c"}} test doption-1.12 {excepted options are caught properly on configure, 1} -body { type tail { option -a a option -b b option -c c } type cat { delegate option * to tail except {-b -c} constructor {args} { set tail [tail %AUTO%] } } cat fifi catch {fifi configure -a 1} a catch {fifi configure -b 1} b catch {fifi configure -c 1} c list $a $b $c } -cleanup { cat destroy tail destroy } -result {{} {unknown option "-b"} {unknown option "-c"}} test doption-1.13 {excepted options are caught properly on configure, 2} -body { type tail { option -a a option -b b option -c c } type cat { delegate option * to tail except {-b -c} constructor {args} { set tail [tail %AUTO%] } } cat fifi catch {fifi configure -a} a catch {fifi configure -b} b catch {fifi configure -c} c list $a $b $c } -cleanup { cat destroy tail destroy } -result {{-a a A a a} {unknown option "-b"} {unknown option "-c"}} test doption-1.14 {configure query skips excepted options} -body { type tail { option -a a option -b b option -c c } type cat { option -d d delegate option * to tail except {-b -c} constructor {args} { set tail [tail %AUTO%] } } cat fifi fifi configure } -cleanup { cat destroy tail destroy } -result {{-d d D d d} {-a a A a a}} #----------------------------------------------------------------------- # from test from-1.1 {getting default values} -body { type dog { option -foo FOO option -bar BAR constructor {args} { $self configure -foo [from args -foo AAA] $self configure -bar [from args -bar] } } dog create spot list [spot cget -foo] [spot cget -bar] } -cleanup { dog destroy } -result {AAA BAR} test from-1.2 {getting non-default values} -body { type dog { option -foo FOO option -bar BAR option -args constructor {args} { $self configure -foo [from args -foo] $self configure -bar [from args -bar] $self configure -args $args } } dog create spot -foo quux -baz frobnitz -bar frobozz list [spot cget -foo] [spot cget -bar] [spot cget -args] } -cleanup { dog destroy } -result {quux frobozz {-baz frobnitz}} #----------------------------------------------------------------------- # Widgetadaptors test widgetadaptor-1.1 {creating a widget: hull hijacking} -constraints { tk } -body { widgetadaptor mylabel { constructor {args} { installhull [label $self] $self configurelist $args } delegate method * to hull delegate option * to hull } mylabel create .label -text "My Label" set a [.label cget -text] set b [hull1.label cget -text] destroy .label tkbide list $a $b } -cleanup { mylabel destroy } -result {{My Label} {My Label}} test widgetadaptor-1.2 {destroying a widget with destroy} -constraints { tk } -body { widgetadaptor mylabel { constructor {} { installhull [label $self] } } mylabel create .label set a [namespace children ::mylabel] destroy .label set b [namespace children ::mylabel] tkbide list $a $b } -cleanup { mylabel destroy } -result {::mylabel::Snit_inst1 {}} test widgetadaptor-1.3 {destroying two widgets of the same type with destroy} -constraints { tk } -body { widgetadaptor mylabel { constructor {} { installhull [label $self] } } mylabel create .lab1 mylabel create .lab2 set a [namespace children ::mylabel] destroy .lab1 destroy .lab2 set b [namespace children ::mylabel] tkbide list $a $b } -cleanup { mylabel destroy } -result {{::mylabel::Snit_inst1 ::mylabel::Snit_inst2} {}} test widgetadaptor-1.4 {destroying a widget with rename, then destroy type} -constraints { tk bug8.5a3 } -body { widgetadaptor mylabel { constructor {} { installhull [label $self] } } mylabel create .label set a [namespace children ::mylabel] rename .label "" set b [namespace children ::mylabel] mylabel destroy tkbide list $a $b } -result {::mylabel::Snit_inst1 {}} test widgetadaptor-1.5 {destroying two widgets of the same type with rename} -constraints { tk bug8.5a3 } -body { widgetadaptor mylabel { constructor {} { installhull [label $self] } } mylabel create .lab1 mylabel create .lab2 set a [namespace children ::mylabel] rename .lab1 "" rename .lab2 "" set b [namespace children ::mylabel] mylabel destroy tkbide list $a $b } -result {{::mylabel::Snit_inst1 ::mylabel::Snit_inst2} {}} test widgetadaptor-1.6 {create/destroy twice, with destroy} -constraints { tk } -body { widgetadaptor mylabel { constructor {} { installhull [label $self] } } mylabel create .lab1 set a [namespace children ::mylabel] destroy .lab1 mylabel create .lab1 set b [namespace children ::mylabel] destroy .lab1 set c [namespace children ::mylabel] mylabel destroy tkbide list $a $b $c } -result {::mylabel::Snit_inst1 ::mylabel::Snit_inst2 {}} test widgetadaptor-1.7 {create/destroy twice, with rename} -constraints { tk bug8.5a3 } -body { widgetadaptor mylabel { constructor {} { installhull [label $self] } } mylabel create .lab1 set a [namespace children ::mylabel] rename .lab1 "" mylabel create .lab1 set b [namespace children ::mylabel] rename .lab1 "" set c [namespace children ::mylabel] mylabel destroy tkbide list $a $b $c } -result {::mylabel::Snit_inst1 ::mylabel::Snit_inst2 {}} test widgetadaptor-1.8 {"create" is optional} -constraints { tk } -body { widgetadaptor mylabel { constructor {args} { installhull [label $self] } method howdy {} {return "Howdy!"} } mylabel .label set a [.label howdy] destroy .label tkbide set a } -cleanup { mylabel destroy } -result {Howdy!} # Case 1 test widgetadaptor-1.9 {"create" is optional, but must be a valid name} -constraints { snit1 tk } -body { widgetadaptor mylabel { constructor {args} { installhull [label $self] } method howdy {} {return "Howdy!"} } catch {mylabel foo} result tkbide set result } -cleanup { mylabel destroy } -result {"::mylabel foo" is not defined} # Case 2 test widgetadaptor-1.10 {"create" is optional, but must be a valid name} -constraints { snit2 tk } -body { widgetadaptor mylabel { constructor {args} { installhull [label $self] } method howdy {} {return "Howdy!"} } catch {mylabel foo} result tkbide set result } -cleanup { mylabel destroy } -result {unknown subcommand "foo": namespace ::mylabel does not export any commands} test widgetadaptor-1.11 {user-defined destructors are called} -constraints { tk } -body { widgetadaptor mylabel { typevariable flag "" constructor {args} { installhull [label $self] set flag "created $self" } destructor { set flag "destroyed $self" } typemethod getflag {} { return $flag } } mylabel .label set a [mylabel getflag] destroy .label tkbide list $a [mylabel getflag] } -cleanup { mylabel destroy } -result {{created .label} {destroyed .label}} # Case 1 test widgetadaptor-1.12 {destroy method not defined for widget types} -constraints { snit1 tk } -body { widgetadaptor mylabel { constructor {args} { installhull [label $self] } } mylabel .label catch {.label destroy} result destroy .label tkbide set result } -cleanup { mylabel destroy } -result {".label destroy" is not defined} # Case 2 test widgetadaptor-1.13 {destroy method not defined for widget types} -constraints { snit2 tk } -body { widgetadaptor mylabel { constructor {args} { installhull [label $self] } } mylabel .label catch {.label destroy} result destroy .label tkbide set result } -cleanup { mylabel destroy } -result {unknown subcommand "destroy": namespace ::mylabel::Snit_inst1 does not export any commands} test widgetadaptor-1.14 {hull can be repeatedly renamed} -constraints { tk } -body { widgetadaptor basetype { constructor {args} { installhull [label $self] } method basemethod {} { return "basemethod" } } widgetadaptor w1 { constructor {args} { installhull [basetype create $self] } } widgetadaptor w2 { constructor {args} { installhull [w1 $self] } } set a [w2 .foo] destroy .foo tkbide set a } -cleanup { w2 destroy w1 destroy basetype destroy } -result {.foo} test widgetadaptor-1.15 {widget names can be generated} -constraints { tk } -body { widgetadaptor unique { constructor {args} { installhull [label $self] } } set w [unique .%AUTO%] destroy $w tkbide set w } -cleanup { unique destroy } -result {.unique1} test widgetadaptor-1.16 {snit::widgetadaptor as hull} -constraints { tk } -body { widgetadaptor mylabel { constructor {args} { installhull [label $self] $self configurelist $args } method method1 {} { return "method1" } delegate option * to hull } widgetadaptor mylabel2 { constructor {args} { installhull [mylabel $self] $self configurelist $args } method method2 {} { return "method2: [$hull method1]" } delegate option * to hull } mylabel2 .label -text "Some Text" set a [.label method2] set b [.label cget -text] .label configure -text "More Text" set c [.label cget -text] set d [namespace children ::mylabel2] set e [namespace children ::mylabel] destroy .label set f [namespace children ::mylabel2] set g [namespace children ::mylabel] mylabel2 destroy mylabel destroy tkbide list $a $b $c $d $e $f $g } -result {{method2: method1} {Some Text} {More Text} ::mylabel2::Snit_inst1 ::mylabel::Snit_inst1 {} {}} test widgetadaptor-1.17 {snit::widgetadaptor as hull; use rename} -constraints { tk bug8.5a3 } -body { widgetadaptor mylabel { constructor {args} { installhull [label $self] $self configurelist $args } method method1 {} { return "method1" } delegate option * to hull } widgetadaptor mylabel2 { constructor {args} { installhull [mylabel $self] $self configurelist $args } method method2 {} { return "method2: [$hull method1]" } delegate option * to hull } mylabel2 .label -text "Some Text" set a [.label method2] set b [.label cget -text] .label configure -text "More Text" set c [.label cget -text] set d [namespace children ::mylabel2] set e [namespace children ::mylabel] rename .label "" set f [namespace children ::mylabel2] set g [namespace children ::mylabel] mylabel2 destroy mylabel destroy tkbide list $a $b $c $d $e $f $g } -result {{method2: method1} {Some Text} {More Text} ::mylabel2::Snit_inst1 ::mylabel::Snit_inst1 {} {}} test widgetadaptor-1.18 {BWidget Label as hull} -constraints { bwidget } -body { widgetadaptor mylabel { constructor {args} { installhull [Label $win] $self configurelist $args } delegate option * to hull } mylabel .label -text "Some Text" set a [.label cget -text] .label configure -text "More Text" set b [.label cget -text] set c [namespace children ::mylabel] destroy .label set d [namespace children ::mylabel] mylabel destroy tkbide list $a $b $c $d } -result {{Some Text} {More Text} ::mylabel::Snit_inst1 {}} test widgetadaptor-1.19 {error in widgetadaptor constructor} -constraints { tk } -body { widgetadaptor mylabel { constructor {args} { error "Simulated Error" } } mylabel .lab } -returnCodes { error } -cleanup { mylabel destroy } -result {Error in constructor: Simulated Error} #----------------------------------------------------------------------- # Widgets # A widget is just a widgetadaptor with an automatically created hull # component (a Tk frame). So the widgetadaptor tests apply; all we # need to test here is the frame creation. test widget-1.1 {creating a widget} -constraints { tk } -body { widget myframe { method hull {} { return $hull } delegate method * to hull delegate option * to hull } myframe create .frm -background green set a [.frm cget -background] set b [.frm hull] destroy .frm tkbide list $a $b } -cleanup { myframe destroy } -result {green ::hull1.frm} test widget-2.1 {can't redefine hull} -constraints { tk } -body { widget myframe { method resethull {} { set hull "" } } myframe .frm .frm resethull } -returnCodes { error } -cleanup { myframe destroy } -result {can't set "hull": The hull component cannot be redefined} #----------------------------------------------------------------------- # install # # The install command is used to install widget components, while getting # options for the option database. test install-1.1 {installed components are created properly} -constraints { tk } -body { widget myframe { # Delegate an option just to make sure the component variable # exists. delegate option -font to text constructor {args} { install text using text $win.text -background green } method getit {} { $win.text cget -background } } myframe .frm set a [.frm getit] destroy .frm tkbide set a } -cleanup { myframe destroy } -result {green} test install-1.2 {installed components are saved properly} -constraints { tk } -body { widget myframe { # Delegate an option just to make sure the component variable # exists. delegate option -font to text constructor {args} { install text using text $win.text -background green } method getit {} { $text cget -background } } myframe .frm set a [.frm getit] destroy .frm tkbide set a } -cleanup { myframe destroy } -result {green} test install-1.3 {can't install until hull exists} -constraints { tk } -body { widgetadaptor myframe { # Delegate an option just to make sure the component variable # exists. delegate option -font to text constructor {args} { install text using text $win.text -background green } } myframe .frm } -returnCodes { error } -cleanup { myframe destroy } -result {Error in constructor: tried to install "text" before the hull exists} test install-1.4 {install queries option database} -constraints { tk } -body { widget myframe { delegate option -font to text typeconstructor { option add *Myframe.font Courier } constructor {args} { install text using text $win.text } } myframe .frm set a [.frm cget -font] destroy .frm tkbide set a } -cleanup { myframe destroy } -result {Courier} test install-1.5 {explicit options override option database} -constraints { tk } -body { widget myframe { delegate option -font to text typeconstructor { option add *Myframe.font Courier } constructor {args} { install text using text $win.text -font Times } } myframe .frm set a [.frm cget -font] destroy .frm tkbide set a } -cleanup { myframe destroy } -result {Times} test install-1.6 {option db works with targetted options} -constraints { tk } -body { widget myframe { delegate option -textfont to text as -font typeconstructor { option add *Myframe.textfont Courier } constructor {args} { install text using text $win.text } } myframe .frm set a [.frm cget -textfont] destroy .frm tkbide set a } -cleanup { myframe destroy } -result {Courier} test install-1.7 {install works for snit::types} -body { type tail { option -tailcolor black } type dog { delegate option -tailcolor to tail constructor {args} { install tail using tail $self.tail } } dog fido fido cget -tailcolor } -cleanup { dog destroy tail destroy } -result {black} test install-1.8 {install can install non-widget components} -constraints { tk } -body { type dog { option -tailcolor black } widget myframe { delegate option -tailcolor to thedog typeconstructor { option add *Myframe.tailcolor green } constructor {args} { install thedog using dog $win.dog } } myframe .frm set a [.frm cget -tailcolor] destroy .frm tkbide set a } -cleanup { dog destroy myframe destroy } -result {green} test install-1.9 {ok if no options are delegated to component} -constraints { tk } -body { type dog { option -tailcolor black } widget myframe { constructor {args} { install thedog using dog $win.dog } } myframe .frm destroy .frm tkbide # Test passes if no error is raised. list ok } -cleanup { myframe destroy dog destroy } -result {ok} test install-2.1 { delegate option * for a non-shadowed option. The text widget's -foreground and -font options should be set according to what's in the option database on the widgetclass. } -constraints { tk } -body { widget myframe { delegate option * to text typeconstructor { option add *Myframe.foreground red option add *Myframe.font {Times 14} } constructor {args} { install text using text $win.text } } myframe .frm set a [.frm cget -foreground] set b [.frm cget -font] destroy .frm tkbide list $a $b } -cleanup { myframe destroy } -result {red {Times 14}} test install-2.2 { Delegate option * for a shadowed option. Foreground is declared as a non-delegated option, hence it will pick up the option database default. -foreground is not included in the "delegate option *", so the text widget's -foreground option will not be set from the option database. } -constraints { tk } -body { widget myframe { option -foreground white delegate option * to text typeconstructor { option add *Myframe.foreground red } constructor {args} { install text using text $win.text } method getit {} { $text cget -foreground } } myframe .frm set a [.frm cget -foreground] set b [.frm getit] destroy .frm tkbide expr {![string equal $a $b]} } -cleanup { myframe destroy } -result {1} test install-2.3 { Delegate option * for a creation option. Because the text widget's -foreground is set explicitly by the constructor, that always overrides the option database. } -constraints { tk } -body { widget myframe { delegate option * to text typeconstructor { option add *Myframe.foreground red } constructor {args} { install text using text $win.text -foreground blue } } myframe .frm set a [.frm cget -foreground] destroy .frm tkbide set a } -cleanup { myframe destroy } -result {blue} test install-2.4 { Delegate option * with an excepted option. Because the text widget's -state is excepted, it won't be set from the option database. } -constraints { tk } -body { widget myframe { delegate option * to text except -state typeconstructor { option add *Myframe.foreground red option add *Myframe.state disabled } constructor {args} { install text using text $win.text } method getstate {} { $text cget -state } } myframe .frm set a [.frm getstate] destroy .frm tkbide set a } -cleanup { myframe destroy } -result {normal} #----------------------------------------------------------------------- # Advanced installhull tests # # installhull is used to install the hull widget for both widgets and # widget adaptors. It has two forms. In one form it installs a widget # created by some third party; in this form no querying of the option # database is needed, because we haven't taken responsibility for creating # it. But in the other form (installhull using) installhull actually # creates the widget, and takes responsibility for querying the # option database as needed. # # NOTE: "installhull using" is always used to create a widget's hull frame. # # That options passed into installhull override those from the # option database. test installhull-1.1 { options delegated to a widget's hull frame with the same name are initialized from the option database. Note that there's no explicit code in Snit to do this; it happens because we set the -class when the widget was created. In fact, it happens whether we delegate the option name or not. } -constraints { tk } -body { widget myframe { delegate option -background to hull typeconstructor { option add *Myframe.background red option add *Myframe.width 123 } method getwid {} { $hull cget -width } } myframe .frm set a [.frm cget -background] set b [.frm getwid] destroy .frm tkbide list $a $b } -cleanup { myframe destroy } -result {red 123} test installhull-1.2 { Options delegated to a widget's hull frame with a different name are initialized from the option database. } -constraints { tk } -body { widget myframe { delegate option -mainbackground to hull as -background typeconstructor { option add *Myframe.mainbackground red } } myframe .frm set a [.frm cget -mainbackground] destroy .frm tkbide set a } -cleanup { myframe destroy } -result {red} test installhull-1.3 { options delegated to a widgetadaptor's hull frame with the same name are initialized from the option database. Note that there's no explicit code in Snit to do this; there's no way to change the adapted hull widget's -class, so the widget is simply being initialized normally. } -constraints { tk } -body { widgetadaptor myframe { delegate option -background to hull typeconstructor { option add *Frame.background red option add *Frame.width 123 } constructor {args} { installhull using frame } method getwid {} { $hull cget -width } } myframe .frm set a [.frm cget -background] set b [.frm getwid] destroy .frm tkbide list $a $b } -cleanup { myframe destroy } -result {red 123} test installhull-1.4 { Options delegated to a widget's hull frame with a different name are initialized from the option database. } -constraints { tk } -body { widgetadaptor myframe { delegate option -mainbackground to hull as -background typeconstructor { option add *Frame.mainbackground red } constructor {args} { installhull using frame } } myframe .frm set a [.frm cget -mainbackground] destroy .frm tkbide set a } -cleanup { myframe destroy } -result {red} test installhull-1.5 { Option values read from the option database are overridden by options explicitly passed, even if delegated under a different name. } -constraints { tk } -body { widgetadaptor myframe { delegate option -mainbackground to hull as -background typeconstructor { option add *Frame.mainbackground red option add *Frame.width 123 } constructor {args} { installhull using frame -background green -width 321 } method getwid {} { $hull cget -width } } myframe .frm set a [.frm cget -mainbackground] set b [.frm getwid] destroy .frm tkbide list $a $b } -cleanup { myframe destroy } -result {green 321} #----------------------------------------------------------------------- # Instance Introspection # Case 1 test iinfo-1.1 {object info too few args} -constraints { snit1 } -body { type dog { } dog create spot spot info } -returnCodes { error } -cleanup { dog destroy } -result [tcltest::wrongNumArgs ::snit::RT.method.info {type selfns win self command args} 4] # Case 2 test iinfo-1.2 {object info too few args} -constraints { snit2 } -body { type dog { } dog create spot spot info } -returnCodes { error } -cleanup { dog destroy } -result [expect \ {wrong # args: should be "spot info command ?arg ...?"} \ {wrong # args: should be "spot info command ..."}] test iinfo-1.3 {object info too many args} -body { type dog { } dog create spot spot info type foo } -returnCodes { error } -cleanup { dog destroy } -result [tcltest::tooManyArgs ::snit::RT.method.info.type {type selfns win self}] test iinfo-2.1 {object info type} -body { type dog { } dog create spot spot info type } -cleanup { dog destroy } -result {::dog} test iinfo-3.1 {object info typevars} -body { type dog { typevariable thisvar 1 constructor {args} { typevariable thatvar 2 } } dog create spot lsort [spot info typevars] } -cleanup { dog destroy } -result {::dog::thatvar ::dog::thisvar} test iinfo-3.2 {object info typevars with pattern} -body { type dog { typevariable thisvar 1 constructor {args} { typevariable thatvar 2 } } dog create spot spot info typevars *this* } -cleanup { dog destroy } -result {::dog::thisvar} test iinfo-4.1 {object info vars} -body { type dog { variable hisvar 1 constructor {args} { variable hervar set hervar 2 } } dog create spot lsort [spot info vars] } -cleanup { dog destroy } -result {::dog::Snit_inst1::hervar ::dog::Snit_inst1::hisvar} test iinfo-4.2 {object info vars with pattern} -body { type dog { variable hisvar 1 constructor {args} { variable hervar set hervar 2 } } dog create spot spot info vars "*his*" } -cleanup { dog destroy } -result {::dog::Snit_inst1::hisvar} test iinfo-5.1 {object info no vars defined} -body { type dog { } dog create spot list [spot info vars] [spot info typevars] } -cleanup { dog destroy } -result {{} {}} test iinfo-6.1 {info options with no options} -body { type dog { } dog create spot llength [spot info options] } -cleanup { dog destroy } -result {0} test iinfo-6.2 {info options with only local options} -body { type dog { option -foo a option -bar b } dog create spot lsort [spot info options] } -cleanup { dog destroy } -result {-bar -foo} test iinfo-6.3 {info options with local and delegated options} -body { type dog { option -foo a option -bar b delegate option -quux to sibling } dog create spot lsort [spot info options] } -cleanup { dog destroy } -result {-bar -foo -quux} test iinfo-6.5 {info options with unknown delegated options} -constraints { tk } -body { widgetadaptor myframe { option -foo a delegate option * to hull constructor {args} { installhull [frame $self] } } myframe .frm set a [lsort [.frm info options]] destroy .frm tkbide set a } -cleanup { myframe destroy } -result [::tcltest::byConstraint { tcl8 {-background -bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief -takefocus -visual -width} tcl9plus {-background -backgroundimage -bd -bg -bgimg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief -takefocus -tile -visual -width} }] test iinfo-6.7 {info options with exceptions} -constraints { tk } -body { widgetadaptor myframe { option -foo a delegate option * to hull except -background constructor {args} { installhull [frame $self] } } myframe .frm set a [lsort [.frm info options]] destroy .frm tkbide set a } -cleanup { myframe destroy } -result [::tcltest::byConstraint { tcl8 {-bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief -takefocus -visual -width} tcl9plus {-backgroundimage -bd -bg -bgimg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief -takefocus -tile -visual -width} }] test iinfo-6.8 {info options with pattern} -constraints { tk } -body { widgetadaptor myframe { option -foo a delegate option * to hull constructor {args} { installhull [frame $self] } } myframe .frm set a [lsort [.frm info options -c*]] destroy .frm tkbide set a } -cleanup { myframe destroy } -result {-class -colormap -container -cursor} test iinfo-7.1 {info typemethods, simple case} -body { type dog { } dog spot lsort [spot info typemethods] } -cleanup { dog destroy } -result {create destroy info} test iinfo-7.2 {info typemethods, with pattern} -body { type dog { } dog spot spot info typemethods i* } -cleanup { dog destroy } -result {info} test iinfo-7.3 {info typemethods, with explicit typemethods} -body { type dog { typemethod foo {} {} delegate typemethod bar to comp } dog spot lsort [spot info typemethods] } -cleanup { dog destroy } -result {bar create destroy foo info} test iinfo-7.4 {info typemethods, with implicit typemethods} -body { type dog { delegate typemethod * to comp typeconstructor { set comp string } } dog create spot set a [lsort [spot info typemethods]] dog length foo dog is boolean yes set b [lsort [spot info typemethods]] set c [spot info typemethods len*] list $a $b $c } -cleanup { dog destroy } -result {{create destroy info} {create destroy info is length} length} test iinfo-7.5 {info typemethods, with hierarchical typemethods} -body { type dog { delegate typemethod {comp foo} to comp typemethod {comp bar} {} {} } dog create spot lsort [spot info typemethods] } -cleanup { dog destroy } -result {{comp bar} {comp foo} create destroy info} test iinfo-8.1 {info methods, simple case} -body { type dog { } dog spot lsort [spot info methods] } -cleanup { dog destroy } -result {destroy info} test iinfo-8.2 {info methods, with pattern} -body { type dog { } dog spot spot info methods i* } -cleanup { dog destroy } -result {info} test iinfo-8.3 {info methods, with explicit methods} -body { type dog { method foo {} {} delegate method bar to comp } dog spot lsort [spot info methods] } -cleanup { dog destroy } -result {bar destroy foo info} test iinfo-8.4 {info methods, with implicit methods} -body { type dog { delegate method * to comp constructor {args} { set comp string } } dog create spot set a [lsort [spot info methods]] spot length foo spot is boolean yes set b [lsort [spot info methods]] set c [spot info methods len*] list $a $b $c } -cleanup { dog destroy } -result {{destroy info} {destroy info is length} length} test iinfo-8.5 {info methods, with hierarchical methods} -body { type dog { delegate method {comp foo} to comp method {comp bar} {} {} } dog create spot lsort [spot info methods] } -cleanup { dog destroy } -result {{comp bar} {comp foo} destroy info} test iinfo-9.1 {info args} -body { type dog { method bark {volume} {} } dog spot spot info args bark } -cleanup { dog destroy } -result {volume} test iinfo-9.2 {info args, too few args} -body { type dog { method bark {volume} {} } dog spot spot info args } -returnCodes error -cleanup { dog destroy } -result [tcltest::wrongNumArgs ::snit::RT.method.info.args {type selfns win self method} 4] test iinfo-9.3 {info args, too many args} -body { type dog { method bark {volume} {} } dog spot spot info args bark wag } -returnCodes error -cleanup { dog destroy } -result [tcltest::tooManyArgs ::snit::RT.method.info.args {type selfns win self method}] test iinfo-9.4 {info args, unknown method} -body { type dog { } dog spot spot info args bark } -returnCodes error -cleanup { dog destroy } -result {Unknown method "bark"} test iinfo-9.5 {info args, delegated method} -body { type dog { component x delegate method bark to x } dog spot spot info args bark } -returnCodes error -cleanup { dog destroy } -result {Delegated method "bark"} test iinfo-10.1 {info default} -body { type dog { method bark {{volume 50}} {} } dog spot list [spot info default bark volume def] $def } -cleanup { dog destroy } -result {1 50} test iinfo-10.2 {info default, too few args} -body { type dog { method bark {volume} {} } dog spot spot info default } -returnCodes error -cleanup { dog destroy } -result [tcltest::wrongNumArgs ::snit::RT.method.info.default {type selfns win self method aname dvar} 4] test iinfo-10.3 {info default, too many args} -body { type dog { method bark {volume} {} } dog spot spot info default bark wag def foo } -returnCodes error -cleanup { dog destroy } -result [tcltest::tooManyArgs ::snit::RT.method.info.default {type selfns win self method aname dvar}] test iinfo-10.4 {info default, unknown method} -body { type dog { } dog spot spot info default bark x var } -returnCodes error -cleanup { dog destroy } -result {Unknown method "bark"} test iinfo-10.5 {info default, delegated method} -body { type dog { component x delegate method bark to x } dog spot spot info default bark x var } -returnCodes error -cleanup { dog destroy } -result {Delegated method "bark"} test iinfo-11.1 {info body} -body { type dog { typevariable x variable y method bark {volume} { speaker on speaker play bark.snd speaker off } } dog spot spot info body bark } -cleanup { dog destroy } -result { speaker on speaker play bark.snd speaker off } test iinfo-11.2 {info body, too few args} -body { type dog { method bark {volume} {} } dog spot spot info body } -returnCodes error -cleanup { dog destroy } -result [tcltest::wrongNumArgs ::snit::RT.method.info.body {type selfns win self method} 4] test iinfo-11.3 {info body, too many args} -body { type dog { method bark {volume} {} } dog spot spot info body bark wag } -returnCodes error -cleanup { dog destroy } -result [tcltest::tooManyArgs ::snit::RT.method.info.body {type selfns win self method}] test iinfo-11.4 {info body, unknown method} -body { type dog { } dog spot spot info body bark } -returnCodes error -cleanup { dog destroy } -result {Unknown method "bark"} test iinfo-11.5 {info body, delegated method} -body { type dog { component x delegate method bark to x } dog spot spot info body bark } -returnCodes error -cleanup { dog destroy } -result {Delegated method "bark"} #----------------------------------------------------------------------- # Type Introspection # Case 1 test tinfo-1.1 {type info too few args} -constraints { snit1 } -body { type dog { } dog info } -returnCodes { error } -cleanup { dog destroy } -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info {type command args} 1] # Case 2 test tinfo-1.2 {type info too few args} -constraints { snit2 } -body { type dog { } dog info } -returnCodes { error } -cleanup { dog destroy } -result [expect \ {wrong # args: should be "dog info command ?arg ...?"} \ {wrong # args: should be "dog info command ..."}] test tinfo-1.3 {type info too many args} -body { type dog { } dog info instances foo bar } -returnCodes { error } -cleanup { dog destroy } -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.instances {type ?pattern?}] test tinfo-2.1 {type info typevars} -body { type dog { typevariable thisvar 1 constructor {args} { typevariable thatvar 2 } } dog create spot lsort [dog info typevars] } -cleanup { dog destroy } -result {::dog::thatvar ::dog::thisvar} test tinfo-3.1 {type info instances} -body { type dog { } dog create spot dog create fido lsort [dog info instances] } -cleanup { dog destroy } -result {::fido ::spot} test tinfo-3.2 {widget info instances} -constraints { tk } -body { widgetadaptor mylabel { constructor {args} { installhull [label $self] } } mylabel .lab1 mylabel .lab2 set result [mylabel info instances] destroy .lab1 destroy .lab2 tkbide lsort $result } -cleanup { mylabel destroy } -result {.lab1 .lab2} test tinfo-3.3 {type info instances with non-global namespaces} -body { type dog { } dog create ::spot namespace eval ::dogs:: { set ::qname [dog create fido] } list $qname [lsort [dog info instances]] } -cleanup { dog destroy } -result {::dogs::fido {::dogs::fido ::spot}} test tinfo-3.4 {type info instances with pattern} -body { type dog { } dog create spot dog create fido dog info instances "*f*" } -cleanup { dog destroy } -result {::fido} test tinfo-3.5 {type info instances with unrelated child namespace, bug 2898640} -body { type dog { } namespace eval dog::unrelated {} dog create fido dog info instances } -cleanup { dog destroy } -result {::fido} test tinfo-4.1 {type info typevars with pattern} -body { type dog { typevariable thisvar 1 constructor {args} { typevariable thatvar 2 } } dog create spot dog info typevars *this* } -cleanup { dog destroy } -result {::dog::thisvar} test tinfo-5.1 {type info typemethods, simple case} -body { type dog { } lsort [dog info typemethods] } -cleanup { dog destroy } -result {create destroy info} test tinfo-5.2 {type info typemethods, with pattern} -body { type dog { } dog info typemethods i* } -cleanup { dog destroy } -result {info} test tinfo-5.3 {type info typemethods, with explicit typemethods} -body { type dog { typemethod foo {} {} delegate typemethod bar to comp } lsort [dog info typemethods] } -cleanup { dog destroy } -result {bar create destroy foo info} test tinfo-5.4 {type info typemethods, with implicit typemethods} -body { type dog { delegate typemethod * to comp typeconstructor { set comp string } } set a [lsort [dog info typemethods]] dog length foo dog is boolean yes set b [lsort [dog info typemethods]] set c [dog info typemethods len*] list $a $b $c } -cleanup { dog destroy } -result {{create destroy info} {create destroy info is length} length} test tinfo-5.5 {info typemethods, with hierarchical typemethods} -body { type dog { delegate typemethod {comp foo} to comp typemethod {comp bar} {} {} } lsort [dog info typemethods] } -cleanup { dog destroy } -result {{comp bar} {comp foo} create destroy info} test tinfo-6.1 {type info args} -body { type dog { typemethod bark {volume} {} } dog info args bark } -cleanup { dog destroy } -result {volume} test tinfo-6.2 {type info args, too few args} -body { type dog { typemethod bark {volume} {} } dog info args } -returnCodes error -cleanup { dog destroy } -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info.args {type method} 1] test tinfo-6.3 {type info args, too many args} -body { type dog { typemethod bark {volume} {} } dog info args bark wag } -returnCodes error -cleanup { dog destroy } -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.args {type method}] test tinfo-6.4 {type info args, unknown method} -body { type dog { } dog info args bark } -returnCodes error -cleanup { dog destroy } -result {Unknown typemethod "bark"} test tinfo-6.5 {type info args, delegated method} -body { type dog { delegate typemethod bark to x } dog info args bark } -returnCodes error -cleanup { dog destroy } -result {Delegated typemethod "bark"} test tinfo-7.1 {type info default} -body { type dog { typemethod bark {{volume 50}} {} } list [dog info default bark volume def] $def } -cleanup { dog destroy } -result {1 50} test tinfo-7.2 {type info default, too few args} -body { type dog { typemethod bark {volume} {} } dog info default } -returnCodes error -cleanup { dog destroy } -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info.default {type method aname dvar} 1] test tinfo-7.3 {type info default, too many args} -body { type dog { typemethod bark {volume} {} } dog info default bark wag def foo } -returnCodes error -cleanup { dog destroy } -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.default {type method aname dvar}] test tinfo-7.4 {type info default, unknown method} -body { type dog { } dog info default bark x var } -returnCodes error -cleanup { dog destroy } -result {Unknown typemethod "bark"} test tinfo-7.5 {type info default, delegated method} -body { type dog { delegate typemethod bark to x } dog info default bark x var } -returnCodes error -cleanup { dog destroy } -result {Delegated typemethod "bark"} test tinfo-8.1 {type info body} -body { type dog { typevariable x variable y typemethod bark {volume} { speaker on speaker play bark.snd speaker off } } dog info body bark } -cleanup { dog destroy } -result { speaker on speaker play bark.snd speaker off } test tinfo-8.2 {type info body, too few args} -body { type dog { typemethod bark {volume} {} } dog info body } -returnCodes error -cleanup { dog destroy } -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info.body {type method} 1] test tinfo-8.3 {type info body, too many args} -body { type dog { typemethod bark {volume} {} } dog info body bark wag } -returnCodes error -cleanup { dog destroy } -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.body {type method}] test tinfo-8.4 {type info body, unknown method} -body { type dog { } dog info body bark } -returnCodes error -cleanup { dog destroy } -result {Unknown typemethod "bark"} test tinfo-8.5 {type info body, delegated method} -body { type dog { delegate typemethod bark to x } dog info body bark } -returnCodes error -cleanup { dog destroy } -result {Delegated typemethod "bark"} #----------------------------------------------------------------------- # Setting the widget class explicitly test widgetclass-1.1 {can't set widgetclass for snit::types} -body { type dog { widgetclass Dog } } -returnCodes { error } -result {widgetclass cannot be set for snit::types} test widgetclass-1.2 {can't set widgetclass for snit::widgetadaptors} -constraints { tk } -body { widgetadaptor dog { widgetclass Dog } } -returnCodes { error } -result {widgetclass cannot be set for snit::widgetadaptors} test widgetclass-1.3 {widgetclass must begin with uppercase letter} -constraints { tk } -body { widget dog { widgetclass dog } } -returnCodes { error } -result {widgetclass "dog" does not begin with an uppercase letter} test widgetclass-1.4 {widgetclass can only be defined once} -constraints { tk } -body { widget dog { widgetclass Dog widgetclass Dog } } -returnCodes { error } -result {too many widgetclass statements} test widgetclass-1.5 {widgetclass set successfully} -constraints { tk } -body { widget dog { widgetclass DogWidget } # The test passes if no error is thrown. list ok } -cleanup { dog destroy } -result {ok} test widgetclass-1.6 {implicit widgetclass applied to hull} -constraints { tk } -body { widget dog { typeconstructor { option add *Dog.background green } method background {} { $hull cget -background } } dog .dog set bg [.dog background] destroy .dog set bg } -cleanup { dog destroy } -result {green} test widgetclass-1.7 {explicit widgetclass applied to hull} -constraints { tk } -body { widget dog { widgetclass DogWidget typeconstructor { option add *DogWidget.background green } method background {} { $hull cget -background } } dog .dog set bg [.dog background] destroy .dog set bg } -cleanup { dog destroy } -result {green} #----------------------------------------------------------------------- # hulltype statement test hulltype-1.1 {can't set hulltype for snit::types} -body { type dog { hulltype Dog } } -returnCodes { error } -result {hulltype cannot be set for snit::types} test hulltype-1.2 {can't set hulltype for snit::widgetadaptors} -constraints { tk } -body { widgetadaptor dog { hulltype Dog } } -returnCodes { error } -result {hulltype cannot be set for snit::widgetadaptors} test hulltype-1.3 {hulltype can be frame} -constraints { tk } -body { widget dog { delegate option * to hull hulltype frame } dog .fido catch {.fido configure -use} result destroy .fido tkbide set result } -cleanup { dog destroy } -result {unknown option "-use"} test hulltype-1.4 {hulltype can be toplevel} -constraints { tk } -body { widget dog { delegate option * to hull hulltype toplevel } dog .fido catch {.fido configure -use} result destroy .fido tkbide set result } -cleanup { dog destroy } -result {-use use Use {} {}} test hulltype-1.5 {hulltype can only be defined once} -constraints { tk } -body { widget dog { hulltype frame hulltype toplevel } } -returnCodes { error } -result {too many hulltype statements} test hulltype-2.1 {list of valid hulltypes} -constraints { tk } -body { lsort $::snit::hulltypes } -result {frame labelframe tk::frame tk::labelframe tk::toplevel toplevel ttk::frame ttk::labelframe} #----------------------------------------------------------------------- # expose statement test expose-1.1 {can't expose nothing} -body { type dog { expose } } -constraints { snit1 } -returnCodes { error } -result [tcltest::wrongNumArgs ::snit::Comp.statement.expose {component ?as? ?methodname?} 0] test expose-1.1a {can't expose nothing} -body { type dog { expose } } -constraints { snit2 } -returnCodes { error } -result [tcltest::wrongNumArgs expose {component ?as? ?methodname?} 0] test expose-1.2 {expose a component that's never installed} -body { type dog { expose tail } dog fido fido tail wag } -returnCodes { error } -cleanup { dog destroy } -result {undefined component "tail"} test expose-1.3 {exposed method returns component command} -body { type tail { } type dog { expose tail constructor {} { install tail using tail $self.tail } destructor { $tail destroy } } dog fido fido tail } -cleanup { dog destroy tail destroy } -result {::fido.tail} test expose-1.4 {exposed method calls component methods} -body { type tail { method wag {args} {return "wag<$args>"} method droop {} {return "droop"} } type dog { expose tail constructor {} { install tail using tail $self.tail } destructor { $tail destroy } } dog fido list [fido tail wag] [fido tail wag abc] [fido tail wag abc def] \ [fido tail droop] } -cleanup { dog destroy tail destroy } -result {wag<> wag {wag} droop} #----------------------------------------------------------------------- # Error handling # # This section verifies that errorInfo and errorCode are propagated # appropriately on error. test error-1.1 {typemethod errors propagate properly} -body { type dog { typemethod generr {} { error bogusError bogusInfo bogusCode } } catch {dog generr} result global errorInfo errorCode list $result [string match "*bogusInfo*" $errorInfo] $errorCode } -cleanup { dog destroy } -result {bogusError 1 bogusCode} test error-1.2 {snit::type constructor errors propagate properly} -body { type dog { constructor {} { error bogusError bogusInfo bogusCode } } catch {dog fido} result global errorInfo errorCode list $result [string match "*bogusInfo*" $errorInfo] $errorCode } -cleanup { dog destroy } -result {{Error in constructor: bogusError} 1 bogusCode} test error-1.3 {snit::widget constructor errors propagate properly} -constraints { tk } -body { widget dog { constructor {args} { error bogusError bogusInfo bogusCode } } catch {dog .fido} result global errorInfo errorCode list $result [string match "*bogusInfo*" $errorInfo] $errorCode } -cleanup { dog destroy } -result {{Error in constructor: bogusError} 1 bogusCode} test error-1.4 {method errors propagate properly} -body { type dog { method generr {} { error bogusError bogusInfo bogusCode } } dog fido catch {fido generr} result global errorInfo errorCode list $result [string match "*bogusInfo*" $errorInfo] $errorCode } -cleanup { dog destroy } -result {bogusError 1 bogusCode} test error-1.5 {onconfigure errors propagate properly} -body { type dog { option -generr onconfigure -generr {value} { error bogusError bogusInfo bogusCode } } dog fido catch {fido configure -generr 0} result global errorInfo errorCode list $result [string match "*bogusInfo*" $errorInfo] $errorCode } -cleanup { dog destroy } -result {bogusError 1 bogusCode} test error-1.6 {oncget errors propagate properly} -body { type dog { option -generr oncget -generr { error bogusError bogusInfo bogusCode } } dog fido catch {fido cget -generr} result global errorInfo errorCode list $result [string match "*bogusInfo*" $errorInfo] $errorCode } -cleanup { dog destroy } -result {bogusError 1 bogusCode} #----------------------------------------------------------------------- # Externally defined typemethods test etypemethod-1.1 {external typemethods can be called as expected} -body { type dog { } typemethod dog foo {a} {return "+$a+"} dog foo bar } -cleanup { dog destroy } -result {+bar+} test etypemethod-1.2 {external typemethods can use typevariables} -body { type dog { typevariable somevar "Howdy" } typemethod dog getvar {} {return $somevar} dog getvar } -cleanup { dog destroy } -result {Howdy} test etypemethod-1.3 {typemethods can be redefined dynamically} -body { type dog { typemethod foo {} { return "foo" } } set a [dog foo] typemethod dog foo {} { return "bar"} set b [dog foo] list $a $b } -cleanup { dog destroy } -result {foo bar} test etypemethod-1.4 {can't define external typemethod if no type} -body { typemethod extremelyraredog foo {} { return "bar"} } -returnCodes { error } -result {no such type: "extremelyraredog"} test etypemethod-2.1 {external hierarchical method, two tokens} -body { type dog { } typemethod dog {wag tail} {} { return "wags tail" } dog wag tail } -cleanup { dog destroy } -result {wags tail} test etypemethod-2.2 {external hierarchical method, three tokens} -body { type dog { } typemethod dog {wag tail proudly} {} { return "wags tail proudly" } dog wag tail proudly } -cleanup { dog destroy } -result {wags tail proudly} test etypemethod-2.3 {external hierarchical method, three tokens} -body { type dog { } typemethod dog {wag tail really high} {} { return "wags tail really high" } dog wag tail really high } -cleanup { dog destroy } -result {wags tail really high} test etypemethod-2.4 {redefinition is OK} -body { type dog { } typemethod dog {wag tail} {} { return "wags tail" } typemethod dog {wag tail} {} { return "wags tail briskly" } dog wag tail } -cleanup { dog destroy } -result {wags tail briskly} test etypemethod-3.1 {prefix/method collision} -body { type dog { typemethod wag {} {} } typemethod dog {wag tail} {} {} } -returnCodes { error } -cleanup { dog destroy } -result {Cannot define "wag tail", "wag" has no submethods.} test etypemethod-3.2 {prefix/method collision} -body { type dog { typemethod {wag tail} {} {} } typemethod dog wag {} {} } -returnCodes { error } -cleanup { dog destroy } -result {Cannot define "wag", "wag" has submethods.} test etypemethod-3.3 {prefix/method collision} -body { type dog { typemethod {wag tail} {} {} } typemethod dog {wag tail proudly} {} {} } -returnCodes { error } -cleanup { dog destroy } -result {Cannot define "wag tail proudly", "wag tail" has no submethods.} test etypemethod-3.4 {prefix/method collision} -body { type dog { typemethod {wag tail proudly} {} {} } typemethod dog {wag tail} {} {} } -returnCodes { error } -cleanup { dog destroy } -result {Cannot define "wag tail", "wag tail" has submethods.} #----------------------------------------------------------------------- # Externally defined methods test emethod-1.1 {external methods can be called as expected} -body { type dog { } method dog bark {a} {return "+$a+"} dog spot spot bark woof } -cleanup { dog destroy } -result {+woof+} test emethod-1.2 {external methods can use typevariables} -body { type dog { typevariable somevar "Hello" } method dog getvar {} {return $somevar} dog spot spot getvar } -cleanup { dog destroy } -result {Hello} test emethod-1.3 {external methods can use variables} -body { type dog { variable somevar "Greetings" } method dog getvar {} {return $somevar} dog spot spot getvar } -cleanup { dog destroy } -result {Greetings} test emethod-1.4 {methods can be redefined dynamically} -body { type dog { method bark {} { return "woof" } } dog spot set a [spot bark] method dog bark {} { return "arf"} set b [spot bark] list $a $b } -cleanup { dog destroy } -result {woof arf} test emethod-1.5 {delegated methods can't be redefined} -body { type dog { delegate method bark to someotherdog } method dog bark {} { return "arf"} } -returnCodes { error } -cleanup { dog destroy } -result {Cannot define "bark", "bark" has been delegated} test emethod-1.6 {can't define external method if no type} -body { method extremelyraredog foo {} { return "bar"} } -returnCodes { error } -result {no such type: "extremelyraredog"} test emethod-2.1 {external hierarchical method, two tokens} -body { type dog { } method dog {wag tail} {} { return "$self wags tail." } dog spot spot wag tail } -cleanup { dog destroy } -result {::spot wags tail.} test emethod-2.2 {external hierarchical method, three tokens} -body { type dog { } method dog {wag tail proudly} {} { return "$self wags tail proudly." } dog spot spot wag tail proudly } -cleanup { dog destroy } -result {::spot wags tail proudly.} test emethod-2.3 {external hierarchical method, three tokens} -body { type dog { } method dog {wag tail really high} {} { return "$self wags tail really high." } dog spot spot wag tail really high } -cleanup { dog destroy } -result {::spot wags tail really high.} test emethod-2.4 {redefinition is OK} -body { type dog { } method dog {wag tail} {} { return "$self wags tail." } method dog {wag tail} {} { return "$self wags tail briskly." } dog spot spot wag tail } -cleanup { dog destroy } -result {::spot wags tail briskly.} test emethod-3.1 {prefix/method collision} -body { type dog { method wag {} {} } method dog {wag tail} {} { return "$self wags tail." } } -returnCodes { error } -cleanup { dog destroy } -result {Cannot define "wag tail", "wag" has no submethods.} test emethod-3.2 {prefix/method collision} -body { type dog { method {wag tail} {} { return "$self wags tail." } } method dog wag {} {} } -returnCodes { error } -cleanup { dog destroy } -result {Cannot define "wag", "wag" has submethods.} test emethod-3.3 {prefix/method collision} -body { type dog { method {wag tail} {} {} } method dog {wag tail proudly} {} { return "$self wags tail." } } -returnCodes { error } -cleanup { dog destroy } -result {Cannot define "wag tail proudly", "wag tail" has no submethods.} test emethod-3.4 {prefix/method collision} -body { type dog { method {wag tail proudly} {} { return "$self wags tail." } } method dog {wag tail} {} {} } -returnCodes { error } -cleanup { dog destroy } -result {Cannot define "wag tail", "wag tail" has submethods.} #----------------------------------------------------------------------- # Macros test macro-1.1 {can't redefine non-macros} -body { snit::macro method {} {} } -returnCodes { error } -result {invalid macro name "method"} test macro-1.2 {can define and use a macro} -body { snit::macro hello {name} { method hello {} "return {Hello, $name!}" } type dog { hello World } dog spot spot hello } -cleanup { dog destroy } -result {Hello, World!} test macro-1.3 {can redefine macro} -body { snit::macro dup {} {} snit::macro dup {} {} set dummy "No error" } -result {No error} test macro-1.4 {can define macro in namespace} -body { snit::macro ::test::goodbye {name} { method goodbye {} "return {Goodbye, $name!}" } type dog { ::test::goodbye World } dog spot spot goodbye } -cleanup { dog destroy } -result {Goodbye, World!} test macro-1.5 {_proc and _variable are defined} -body { snit::macro testit {} { set a [info commands _variable] set b [info commands _proc] method testit {} "list $a $b" } type dog { testit } dog spot spot testit } -cleanup { dog destroy } -result {_variable _proc} test macro-1.6 {_variable works} -body { snit::macro test1 {} { _variable myvar "_variable works" } snit::macro test2 {} { _variable myvar method testit {} "return {$myvar}" } type dog { test1 test2 } dog spot spot testit } -cleanup { dog destroy } -result {_variable works} #----------------------------------------------------------------------- # Component Statement test component-1.1 {component defines an instance variable} -body { type dog { component tail } dog spot namespace tail [spot info vars tail] } -cleanup { dog destroy } -result {tail} test component-1.2 {-public exposes the component} -body { type tail { method wag {} { return "Wag, wag" } } type dog { component tail -public mytail constructor {} { set tail [tail %AUTO%] } } dog spot spot mytail wag } -cleanup { dog destroy tail destroy } -result {Wag, wag} test component-1.3 {-inherit requires a boolean value} -body { type dog { component animal -inherit foo } } -returnCodes { error } -result {component animal -inherit: expected boolean value, got "foo"} test component-1.4 {-inherit delegates unknown methods to the component} -body { type animal { method eat {} { return "Eat, eat." } } type dog { component animal -inherit yes constructor {} { set animal [animal %AUTO%] } } dog spot spot eat } -cleanup { dog destroy animal destroy } -result {Eat, eat.} test component-1.5 {-inherit delegates unknown options to the component} -body { type animal { option -size medium } type dog { component animal -inherit yes constructor {} { set animal [animal %AUTO%] } } dog spot spot cget -size } -cleanup { dog destroy animal destroy } -result {medium} #----------------------------------------------------------------------- # Typevariables, Variables, Typecomponents, Components test typevar_var-1.1 {variable/typevariable collisions not allowed: order 1} -body { type dog { typevariable var variable var } } -returnCodes { error } -result {Error in "variable var...", "var" is already a typevariable} test typevar_var-1.2 {variable/typevariable collisions not allowed: order 2} -body { type dog { variable var typevariable var } } -returnCodes { error } -result {Error in "typevariable var...", "var" is already an instance variable} test typevar_var-1.3 {component/typecomponent collisions not allowed: order 1} -body { type dog { typecomponent comp component comp } } -returnCodes { error } -result {Error in "component comp...", "comp" is already a typevariable} test typevar_var-1.4 {component/typecomponent collisions not allowed: order 2} -body { type dog { component comp typecomponent comp } } -returnCodes { error } -result {Error in "typecomponent comp...", "comp" is already an instance variable} test typevar_var-1.5 {can't delegate options to typecomponents} -body { type dog { typecomponent comp delegate option -opt to comp } } -returnCodes { error } -result {Error in "delegate option -opt...", "comp" is already a typevariable} test typevar_var-1.6 {can't delegate typemethods to instance components} -body { type dog { component comp delegate typemethod foo to comp } } -returnCodes { error } -result {Error in "delegate typemethod foo...", "comp" is already an instance variable} test typevar_var-1.7 {can delegate methods to typecomponents} -body { proc echo {args} {return [join $args "|"]} type dog { typecomponent tail typeconstructor { set tail echo } delegate method wag to tail } dog spot spot wag briskly } -cleanup { dog destroy rename echo "" } -result {wag|briskly} #----------------------------------------------------------------------- # Option syntax tests. # # This set of tests verifies that the option statement is interpreted # properly, that errors are caught, and that the type's optionInfo # array is initialized properly. # # TBD: At some point, this needs to be folded into the regular # option tests. test optionsyntax-1.1 {local option names are saved} -body { type dog { option -foo option -bar } set ::dog::Snit_optionInfo(local) } -cleanup { dog destroy } -result {-foo -bar} test optionsyntax-1.2 {islocal flag is set} -body { type dog { option -foo } set ::dog::Snit_optionInfo(islocal--foo) } -cleanup { dog destroy } -result {1} test optionsyntax-2.1 {implicit resource and class} -body { type dog { option -foo } list \ $::dog::Snit_optionInfo(resource--foo) \ $::dog::Snit_optionInfo(class--foo) } -cleanup { dog destroy } -result {foo Foo} test optionsyntax-2.2 {explicit resource, default class} -body { type dog { option {-foo ffoo} } list \ $::dog::Snit_optionInfo(resource--foo) \ $::dog::Snit_optionInfo(class--foo) } -cleanup { dog destroy } -result {ffoo Ffoo} test optionsyntax-2.3 {explicit resource and class} -body { type dog { option {-foo ffoo FFoo} } list \ $::dog::Snit_optionInfo(resource--foo) \ $::dog::Snit_optionInfo(class--foo) } -cleanup { dog destroy } -result {ffoo FFoo} test optionsyntax-2.4 {can't redefine explicit resource} -body { type dog { option {-foo ffoo} option {-foo foo} } } -returnCodes { error } -result {Error in "option {-foo foo}...", resource name redefined from "ffoo" to "foo"} test optionsyntax-2.5 {can't redefine explicit class} -body { type dog { option {-foo ffoo Ffoo} option {-foo ffoo FFoo} } } -returnCodes { error } -result {Error in "option {-foo ffoo FFoo}...", class name redefined from "Ffoo" to "FFoo"} test optionsyntax-2.6 {can redefine implicit resource and class} -body { type dog { option -foo option {-foo ffoo} option {-foo ffoo FFoo} option -foo } } -cleanup { dog destroy } -result {::dog} test optionsyntax-3.1 {no default value} -body { type dog { option -foo } set ::dog::Snit_optionInfo(default--foo) } -cleanup { dog destroy } -result {} test optionsyntax-3.2 {default value, old syntax} -body { type dog { option -foo bar } set ::dog::Snit_optionInfo(default--foo) } -cleanup { dog destroy } -result {bar} test optionsyntax-3.3 {option definition options can be set} -body { type dog { option -foo \ -default Bar \ -validatemethod Validate \ -configuremethod Configure \ -cgetmethod Cget \ -readonly 1 } list \ $::dog::Snit_optionInfo(default--foo) \ $::dog::Snit_optionInfo(validate--foo) \ $::dog::Snit_optionInfo(configure--foo) \ $::dog::Snit_optionInfo(cget--foo) \ $::dog::Snit_optionInfo(readonly--foo) } -cleanup { dog destroy } -result {Bar Validate Configure Cget 1} test optionsyntax-3.4 {option definition option values accumulate} -body { type dog { option -foo -default Bar option -foo -validatemethod Validate option -foo -configuremethod Configure option -foo -cgetmethod Cget option -foo -readonly 1 } list \ $::dog::Snit_optionInfo(default--foo) \ $::dog::Snit_optionInfo(validate--foo) \ $::dog::Snit_optionInfo(configure--foo) \ $::dog::Snit_optionInfo(cget--foo) \ $::dog::Snit_optionInfo(readonly--foo) } -cleanup { dog destroy } -result {Bar Validate Configure Cget 1} test optionsyntax-3.5 {option definition option values can be redefined} -body { type dog { option -foo -default Bar option -foo -validatemethod Validate option -foo -configuremethod Configure option -foo -cgetmethod Cget option -foo -readonly 1 option -foo -default Bar2 option -foo -validatemethod Validate2 option -foo -configuremethod Configure2 option -foo -cgetmethod Cget2 option -foo -readonly 0 } list \ $::dog::Snit_optionInfo(default--foo) \ $::dog::Snit_optionInfo(validate--foo) \ $::dog::Snit_optionInfo(configure--foo) \ $::dog::Snit_optionInfo(cget--foo) \ $::dog::Snit_optionInfo(readonly--foo) } -cleanup { dog destroy } -result {Bar2 Validate2 Configure2 Cget2 0} test optionsyntax-3.6 {option -readonly defaults to 0} -body { type dog { option -foo } set ::dog::Snit_optionInfo(readonly--foo) } -cleanup { dog destroy } -result {0} test optionsyntax-3.7 {option -readonly can be any boolean} -body { type dog { option -foo -readonly 0 option -foo -readonly 1 option -foo -readonly y option -foo -readonly n } } -cleanup { dog destroy } -result {::dog} test optionsyntax-3.8 {option -readonly must be a boolean} -body { type dog { option -foo -readonly foo } } -returnCodes { error } -result {Error in "option -foo...", -readonly requires a boolean, got "foo"} test optionsyntax-3.9 {option -readonly can't be empty} -body { type dog { option -foo -readonly {} } } -returnCodes { error } -result {Error in "option -foo...", -readonly requires a boolean, got ""} #----------------------------------------------------------------------- # 'delegate option' Syntax tests. # # This set of tests verifies that the 'delegation option' statement is # interpreted properly, and that the type's optionInfo # array is initialized properly. # # TBD: At some point, this needs to be folded into the regular # option tests. test delegateoptionsyntax-1.1 {'delegated' lists delegated option names} -body { type dog { delegate option -foo to comp delegate option -bar to comp } set ::dog::Snit_optionInfo(delegated) } -cleanup { dog destroy } -result {-foo -bar} test delegateoptionsyntax-1.2 {'delegated' does not include '*'} -body { type dog { delegate option * to comp } set ::dog::Snit_optionInfo(delegated) } -cleanup { dog destroy } -result {} test delegateoptionsyntax-1.3 {'islocal' is set to 0} -body { type dog { delegate option -foo to comp } set ::dog::Snit_optionInfo(islocal--foo) } -cleanup { dog destroy } -result {0} test delegateoptionsyntax-1.4 {'islocal' is not set for '*'} -body { type dog { delegate option * to comp } info exists ::dog::Snit_optionInfo(islocal-*) } -cleanup { dog destroy } -result {0} test delegateoptionsyntax-1.5 {'delegated-$comp' lists options for the component} -body { type dog { delegate option -foo to comp1 delegate option -bar to comp1 delegate option -baz to comp2 # The * won't show up. delegate option * to comp2 } list \ $::dog::Snit_optionInfo(delegated-comp1) \ $::dog::Snit_optionInfo(delegated-comp2) } -cleanup { dog destroy } -result {{-foo -bar} -baz} test delegateoptionsyntax-1.6 {'except' is empty by default} -body { type dog { delegate option -foo to comp } set ::dog::Snit_optionInfo(except) } -cleanup { dog destroy } -result {} test delegateoptionsyntax-1.7 {'except' lists exceptions} -body { type dog { delegate option * to comp except {-foo -bar -baz} } set ::dog::Snit_optionInfo(except) } -cleanup { dog destroy } -result {-foo -bar -baz} test delegateoptionsyntax-1.8 {'target-$opt' set with default} -body { type dog { delegate option -foo to comp } set ::dog::Snit_optionInfo(target--foo) } -cleanup { dog destroy } -result {comp -foo} test delegateoptionsyntax-1.9 {'target-$opt' set explicitly} -body { type dog { delegate option -foo to comp as -bar } set ::dog::Snit_optionInfo(target--foo) } -cleanup { dog destroy } -result {comp -bar} test delegateoptionsyntax-1.10 {'starcomp' is {} by default} -body { type dog { delegate option -foo to comp } set ::dog::Snit_optionInfo(starcomp) } -cleanup { dog destroy } -result {} test delegateoptionsyntax-1.11 {'starcomp' set for *} -body { type dog { delegate option * to comp } set ::dog::Snit_optionInfo(starcomp) } -cleanup { dog destroy } -result {comp} test delegatedoptionsyntax-2.1 {implicit resource and class} -body { type dog { delegate option -foo to comp } list \ $::dog::Snit_optionInfo(resource--foo) \ $::dog::Snit_optionInfo(class--foo) } -cleanup { dog destroy } -result {foo Foo} test delegatedoptionsyntax-2.2 {explicit resource, default class} -body { type dog { delegate option {-foo ffoo} to comp } list \ $::dog::Snit_optionInfo(resource--foo) \ $::dog::Snit_optionInfo(class--foo) } -cleanup { dog destroy } -result {ffoo Ffoo} test delegatedoptionsyntax-2.3 {explicit resource and class} -body { type dog { delegate option {-foo ffoo FFoo} to comp } list \ $::dog::Snit_optionInfo(resource--foo) \ $::dog::Snit_optionInfo(class--foo) } -cleanup { dog destroy } -result {ffoo FFoo} test delegatedoptionsyntax-2.4 {* doesn't get resource and class} -body { type dog { delegate option * to comp } list \ [info exist ::dog::Snit_optionInfo(resource-*)] \ [info exist ::dog::Snit_optionInfo(class-*)] } -cleanup { dog destroy } -result {0 0} #----------------------------------------------------------------------- # Cget cache test cgetcache-1.1 {Instance rename invalidates cache} -body { type dog { option -foo -default bar -cgetmethod getfoo method getfoo {option} { return $options($option) } } dog fido -foo quux # Cache the cget command. fido cget -foo rename fido spot spot cget -foo } -cleanup { dog destroy } -result {quux} test cgetcache-1.2 {Component rename invalidates cache} -body { type tail { option -foo bar } type dog { delegate option -foo to tail constructor {args} { set tail [tail %AUTO%] $tail configure -foo quux } method retail {} { set tail [tail %AUTO%] } } dog fido # Cache the cget command. fido cget -foo # Invalidate the cache fido retail fido cget -foo } -cleanup { dog destroy tail destroy } -result {bar} # case 1 test cgetcache-1.3 {Invalid -cgetmethod causes error} -constraints { snit1 } -body { type dog { option -foo -default bar -cgetmethod bogus } dog fido -foo quux fido cget -foo } -returnCodes { error } -cleanup { dog destroy } -result {can't cget -foo, "::fido bogus" is not defined} # case 2 test cgetcache-1.4 {Invalid -cgetmethod causes error} -constraints { snit2 } -body { type dog { option -foo -default bar -cgetmethod bogus } dog fido -foo quux fido cget -foo } -returnCodes { error } -cleanup { dog destroy } -result {unknown subcommand "bogus": must be cget, or configurelist} test cgetcache-1.5 {hierarchical -cgetmethod} -body { type dog { option -foo -default bar -cgetmethod {Get Opt} method {Get Opt} {option} { return Dummy } } dog fido fido cget -foo } -cleanup { dog destroy } -result {Dummy} #----------------------------------------------------------------------- # Configure cache test configurecache-1.1 {Instance rename invalidates cache} -body { type dog { option -foo -default bar -configuremethod setfoo method setfoo {option value} { $self setoption $option $value } method setoption {option value} { set options($option) $value } } # Set the option on creation; this will cache the # configure command. dog fido -foo quux rename fido spot spot configure -foo baz spot cget -foo } -cleanup { dog destroy } -result {baz} test configurecache-1.2 {Component rename invalidates cache} -body { type tail { option -foo bar } type dog { delegate option -foo to tail constructor {args} { set tail [tail thistail] $self configurelist $args } method retail {} { # Give it a new component set tail [tail thattail] } } # Set the tail's -foo, and cache the command. dog fido -foo quux # Invalidate the cache fido retail # Should recache, and set the new tail's option. fido configure -foo baz fido cget -foo } -cleanup { dog destroy tail destroy } -result {baz} # Case 1 test configurecache-1.3 {Invalid -configuremethod causes error} -constraints { snit1 } -body { type dog { option -foo -default bar -configuremethod bogus } dog fido fido configure -foo quux } -returnCodes { error } -cleanup { dog destroy } -result {can't configure -foo, "::fido bogus" is not defined} # Case 2 test configurecache-1.4 {Invalid -configuremethod causes error} -constraints { snit2 } -body { type dog { option -foo -default bar -configuremethod bogus } dog fido fido configure -foo quux } -returnCodes { error } -cleanup { dog destroy } -result {unknown subcommand "bogus": must be configure, or configurelist} test configurecache-1.5 {hierarchical -configuremethod} -body { type dog { option -foo -default bar -configuremethod {Set Opt} method {Set Opt} {option value} { set options($option) Dummy } } dog fido -foo NotDummy fido cget -foo } -cleanup { dog destroy } -result {Dummy} #----------------------------------------------------------------------- # option -validatemethod test validatemethod-1.1 {Validate method is called} -body { type dog { variable flag 0 option -color \ -default black \ -validatemethod ValidateColor method ValidateColor {option value} { set flag 1 } method getflag {} { return $flag } } dog fido -color brown fido getflag } -cleanup { dog destroy } -result {1} test validatemethod-1.2 {Validate method gets correct arguments} -body { type dog { option -color \ -default black \ -validatemethod ValidateColor method ValidateColor {option value} { if {![string equal $option "-color"] || ![string equal $value "brown"]} { error "Expected '-color brown'" } } } dog fido -color brown } -cleanup { dog destroy } -result {::fido} # Case 1 test validatemethod-1.3 {Invalid -validatemethod causes error} -constraints { snit1 } -body { type dog { option -foo -default bar -validatemethod bogus } dog fido fido configure -foo quux } -returnCodes { error } -cleanup { dog destroy } -result {can't validate -foo, "::fido bogus" is not defined} # Case 2 test validatemethod-1.4 {Invalid -validatemethod causes error} -constraints { snit2 } -body { type dog { option -foo -default bar -validatemethod bogus } dog fido fido configure -foo quux } -returnCodes { error } -cleanup { dog destroy } -result {unknown subcommand "bogus": must be configure, or configurelist} test validatemethod-1.5 {hierarchical -validatemethod} -body { type dog { option -foo -default bar -validatemethod {Val Opt} method {Val Opt} {option value} { error "Dummy" } } dog fido -foo value } -returnCodes { error } -cleanup { dog destroy } -result {Error in constructor: Dummy} #----------------------------------------------------------------------- # option -readonly semantics test optionreadonly-1.1 {Readonly options can be set at creation time} -body { type dog { option -color \ -default black \ -readonly true } dog fido -color brown fido cget -color } -cleanup { dog destroy } -result {brown} test optionreadonly-1.2 {Readonly options can't be set after creation} -body { type dog { option -color \ -default black \ -readonly true } dog fido fido configure -color brown } -returnCodes { error } -cleanup { dog destroy } -result {option -color can only be set at instance creation} test optionreadonly-1.3 {Readonly options can't be set after creation} -body { type dog { option -color \ -default black \ -readonly true } dog fido -color yellow fido configure -color brown } -returnCodes { error } -cleanup { dog destroy } -result {option -color can only be set at instance creation} #----------------------------------------------------------------------- # Pragma -hastypeinfo test hastypeinfo-1.1 {$type info is defined by default} -body { type dog { typevariable foo } dog info typevars } -cleanup { dog destroy } -result {::dog::foo} # Case 1 test hastypeinfo-1.2 {$type info can be disabled} -constraints { snit1 } -body { type dog { pragma -hastypeinfo no typevariable foo } dog info typevars } -returnCodes { error } -cleanup { dog destroy } -result {"::dog info" is not defined} # Case 2 test hastypeinfo-1.3 {$type info can be disabled} -constraints { snit2 } -body { type dog { pragma -hastypeinfo no typevariable foo } dog info typevars } -returnCodes { error } -cleanup { dog destroy } -result {unknown subcommand "info": namespace ::dog does not export any commands} #----------------------------------------------------------------------- # Pragma -hastypedestroy test hastypedestroy-1.1 {$type destroy is defined by default} -body { type dog { typevariable foo } dog destroy ::dog info typevars } -returnCodes { error } -result {invalid command name "::dog"} # Case 1 test hastypedestroy-1.2 {$type destroy can be disabled} -constraints { snit1 } -body { type dog { pragma -hastypedestroy no typevariable foo } dog destroy } -returnCodes { error } -cleanup { rename ::dog "" namespace delete ::dog } -result {"::dog destroy" is not defined} # Case 2 test hastypedestroy-1.3 {$type destroy can be disabled} -constraints { snit2 } -body { type dog { pragma -hastypedestroy no typevariable foo } dog destroy } -returnCodes { error } -cleanup { rename ::dog "" namespace delete ::dog } -result {unknown subcommand "destroy": namespace ::dog does not export any commands} #----------------------------------------------------------------------- # Pragma -hasinstances test hasinstances-1.1 {-hasinstances is true by default} -body { type dog { method bark {} { return "Woof" } } dog fido fido bark } -cleanup { dog destroy } -result {Woof} # Case 1 test hasinstances-1.2 {'-hasinstances no' disables explicit object creation} -constraints { snit1 } -body { type dog { pragma -hasinstances no } dog create fido } -returnCodes { error } -cleanup { dog destroy } -result {"::dog create" is not defined} # Case 2 test hasinstances-1.3 {'-hasinstances no' disables explicit object creation} -constraints { snit2 } -body { type dog { pragma -hasinstances no } dog create fido } -returnCodes { error } -cleanup { dog destroy } -result {unknown subcommand "create": namespace ::dog does not export any commands} # Case 1 test hasinstances-1.4 {'-hasinstances no' disables implicit object creation} -constraints { snit1 } -body { type dog { pragma -hasinstances no } dog fido } -returnCodes { error } -result {"::dog fido" is not defined} # Case 2 test hasinstances-1.5 {'-hasinstances no' disables implicit object creation} -constraints { snit2 } -body { type dog { pragma -hasinstances no } dog fido } -returnCodes { error } -result {unknown subcommand "fido": namespace ::dog does not export any commands} #----------------------------------------------------------------------- # pragma -canreplace test canreplace-1.1 {By default, "-canreplace no"} -body { type dog { # ... } dog fido dog fido } -returnCodes { error } -cleanup { dog destroy } -result {command "::fido" already exists} test canreplace-1.2 {Can replace commands when "-canreplace yes"} -constraints { bug8.5a3 } -body { type dog { pragma -canreplace yes } dog fido dog fido } -cleanup { dog destroy } -result {::fido} #----------------------------------------------------------------------- # pragma -hasinfo test hasinfo-1.1 {$obj info is defined by default} -body { type dog { variable foo "" } dog spot spot info vars } -cleanup { dog destroy } -result {::dog::Snit_inst1::foo} # Case 1 test hasinfo-1.2 {$obj info can be disabled} -constraints { snit1 } -body { type dog { pragma -hasinfo no variable foo } dog spot spot info vars } -returnCodes { error } -cleanup { dog destroy } -result {"::spot info" is not defined} # Case 2 test hasinfo-1.3 {$obj info can be disabled} -constraints { snit2 } -body { type dog { pragma -hasinfo no variable foo } dog spot spot info vars } -returnCodes { error } -cleanup { dog destroy } -result {unknown subcommand "info": namespace ::dog::Snit_inst1 does not export any commands} #----------------------------------------------------------------------- # pragma -hastypemethods # # The "-hastypemethods yes" case is tested by the bulk of this file. # We'll test the "-hastypemethods no" case here. test hastypemethods-1.1 {-hastypemethods no, $type foo creates instance.} -body { type dog { pragma -hastypemethods no variable foo } dog spot } -cleanup { spot destroy rename ::dog "" namespace delete ::dog } -result {::spot} test hastypemethods-1.2 {-hastypemethods no, $type create foo fails.} -body { type dog { pragma -hastypemethods no variable foo } dog create spot } -returnCodes { error } -cleanup { rename ::dog "" namespace delete ::dog } -result "Error in constructor: [tcltest::tooManyArgs ::dog::Snit_constructor {type selfns win self}]" test hastypemethods-1.3 {-hastypemethods no, $type info fails.} -body { type dog { pragma -hastypemethods no variable foo } dog info } -returnCodes { error } -cleanup { rename ::dog "" namespace delete ::dog } -result {command "::info" already exists} test hastypemethods-1.4 {-hastypemethods no, [$widget] fails.} -constraints { tk } -body { widget dog { pragma -hastypemethods no variable foo } dog } -returnCodes { error } -cleanup { rename ::dog "" namespace delete ::dog } -result {wrong # args: should be "::dog name args"} test hastypemethods-1.5 {-hastypemethods no, -hasinstances no fails.} -body { type dog { pragma -hastypemethods no pragma -hasinstances no variable foo } } -returnCodes { error } -result {type ::dog has neither typemethods nor instances} #----------------------------------------------------------------------- # -simpledispatch yes test simpledispatch-1.1 {not allowed with method delegation.} -constraints { snit1 } -body { type dog { pragma -simpledispatch yes delegate method foo to bar } } -returnCodes { error } -result {type ::dog requests -simpledispatch but delegates methods.} test simpledispatch-1.2 {normal methods work with simpledispatch.} -constraints { snit1 } -body { type dog { pragma -simpledispatch yes method barks {how} { return "$self barks $how." } } dog spot spot barks loudly } -cleanup { dog destroy } -result {::spot barks loudly.} test simpledispatch-1.3 {option methods work with simpledispatch.} -constraints { snit1 } -body { type dog { pragma -simpledispatch yes option -breed mutt } dog spot set a [spot cget -breed] spot configure -breed collie set b [spot cget -breed] spot configurelist [list -breed sheltie] set c [spot cget -breed] list $a $b $c } -cleanup { dog destroy } -result {mutt collie sheltie} test simpledispatch-1.4 {info method works with simpledispatch.} -constraints { snit1 } -body { type dog { pragma -simpledispatch yes option -breed mutt } dog spot spot info options } -cleanup { dog destroy } -result {-breed} test simpledispatch-1.5 {destroy method works with simpledispatch.} -constraints { snit1 } -body { type dog { pragma -simpledispatch yes option -breed mutt } dog spot set a [info commands ::spot] spot destroy set b [info commands ::spot] list $a $b } -cleanup { dog destroy } -result {::spot {}} test simpledispatch-1.6 {no hierarchical methods with simpledispatch.} -constraints { snit1 } -body { type dog { pragma -simpledispatch yes method {wag tail} {} {} } } -returnCodes { error } -result {type ::dog requests -simpledispatch but defines hierarchical methods.} #----------------------------------------------------------------------- # Exotic return codes test break-1.1 {Methods can "return -code break"} -body { snit::type dog { method bark {} {return -code break "Breaking"} } dog spot catch {spot bark} result } -cleanup { dog destroy } -result {3} test break-1.2 {Typemethods can "return -code break"} -body { snit::type dog { typemethod bark {} {return -code break "Breaking"} } catch {dog bark} result } -cleanup { dog destroy } -result {3} test break-1.3 {Methods called via mymethod "return -code break"} -body { snit::type dog { method bark {} {return -code break "Breaking"} method getbark {} { return [mymethod bark] } } dog spot catch {uplevel \#0 [spot getbark]} result } -cleanup { dog destroy } -result {3} #----------------------------------------------------------------------- # Namespace path test nspath-1.1 {Typemethods call commands from parent namespace} -constraints { snit2 } -body { namespace eval ::snit_test:: { proc bark {} {return "[namespace current]: Woof"} } snit::type ::snit_test::dog { typemethod bark {} { bark } } ::snit_test::dog bark } -cleanup { ::snit_test::dog destroy namespace forget ::snit_test } -result {::snit_test: Woof} test nspath-1.2 {Methods can call commands from parent namespace} -constraints { snit2 } -body { namespace eval ::snit_test:: { proc bark {} {return "[namespace current]: Woof"} } snit::type ::snit_test::dog { method bark {} { bark } } ::snit_test::dog spot spot bark } -cleanup { ::snit_test::dog destroy namespace forget ::snit_test } -result {::snit_test: Woof} #----------------------------------------------------------------------- # snit::boolean test boolean-1.1 {boolean: valid} -body { snit::boolean validate 1 snit::boolean validate 0 snit::boolean validate true snit::boolean validate false snit::boolean validate yes snit::boolean validate no snit::boolean validate on snit::boolean validate off } -result {off} test boolean-1.2 {boolean: invalid} -body { codecatch {snit::boolean validate quux} } -result {INVALID invalid boolean "quux", should be one of: 1, 0, true, false, yes, no, on, off} test boolean-2.1 {boolean subtype: valid} -body { snit::boolean subtype subtype validate 1 subtype validate 0 subtype validate true subtype validate false subtype validate yes subtype validate no subtype validate on subtype validate off } -cleanup { subtype destroy } -result {off} test boolean-2.2 {boolean subtype: invalid} -body { snit::boolean subtype codecatch {subtype validate quux} } -cleanup { subtype destroy } -result {INVALID invalid boolean "quux", should be one of: 1, 0, true, false, yes, no, on, off} #----------------------------------------------------------------------- # snit::double test double-1.1 {double: invalid -min} -body { snit::double obj -min abc } -returnCodes { error } -result {Error in constructor: invalid -min: "abc"} test double-1.2 {double: invalid -max} -body { snit::double obj -max abc } -returnCodes { error } -result {Error in constructor: invalid -max: "abc"} test double-1.3 {double: invalid, max < min} -body { snit::double obj -min 5 -max 0 } -returnCodes { error } -result {Error in constructor: -max < -min} test double-2.1 {double type: valid} -body { snit::double validate 1.5 } -result {1.5} test double-2.2 {double type: invalid} -body { codecatch {snit::double validate abc} } -result {INVALID invalid value "abc", expected double} test double-3.1 {double subtype: valid, no range} -body { snit::double subtype subtype validate 1.5 } -cleanup { subtype destroy } -result {1.5} test double-3.2 {double subtype: valid, min but no max} -body { snit::double subtype -min 0.5 subtype validate 1 } -cleanup { subtype destroy } -result {1} test double-3.3 {double subtype: valid, min and max} -body { snit::double subtype -min 0.5 -max 10.5 subtype validate 1.5 } -cleanup { subtype destroy } -result {1.5} test double-4.1 {double subtype: not a number} -body { snit::double subtype codecatch {subtype validate quux} } -cleanup { subtype destroy } -result {INVALID invalid value "quux", expected double} test double-4.2 {double subtype: less than min, no max} -body { snit::double subtype -min 0.5 codecatch {subtype validate -1} } -cleanup { subtype destroy } -result {INVALID invalid value "-1", expected double no less than 0.5} test double-4.3 {double subtype: less than min, with max} -body { snit::double subtype -min 0.5 -max 5.5 codecatch {subtype validate -1} } -cleanup { subtype destroy } -result {INVALID invalid value "-1", expected double in range 0.5, 5.5} test double-4.4 {double subtype: greater than max, no min} -body { snit::double subtype -max 0.5 codecatch {subtype validate 1} } -cleanup { subtype destroy } -result {INVALID invalid value "1", expected double no greater than 0.5} #----------------------------------------------------------------------- # snit::enum test enum-1.1 {enum: valid} -body { snit::enum validate foo } -result {foo} test enum-2.1 {enum subtype: missing -values} -body { snit::enum subtype } -returnCodes { error } -result {Error in constructor: invalid -values: ""} test enum-3.1 {enum subtype: valid} -body { snit::enum subtype -values {foo bar baz} subtype validate foo subtype validate bar subtype validate baz } -cleanup { subtype destroy } -result {baz} test enum-3.2 {enum subtype: invalid} -body { snit::enum subtype -values {foo bar baz} codecatch {subtype validate quux} } -cleanup { subtype destroy } -result {INVALID invalid value "quux", should be one of: foo, bar, baz} #----------------------------------------------------------------------- # snit::fpixels test fpixels-1.1 {no suffix} -constraints tk -body { snit::fpixels validate 5 } -result {5} test fpixels-1.2 {suffix} -constraints tk -body { snit::fpixels validate 5i } -result {5i} test fpixels-1.3 {decimal} -constraints tk -body { snit::fpixels validate 5.5 } -result {5.5} test fpixels-1.4 {invalid} -constraints tk -body { codecatch {snit::fpixels validate 5.5abc} } -result {INVALID invalid value "5.5abc", expected fpixels} test fpixels-2.1 {bad -min} -constraints tk -body { snit::fpixels subtype -min abc } -returnCodes { error } -result {Error in constructor: invalid -min: "abc"} test fpixels-2.2 {bad -max} -constraints tk -body { snit::fpixels subtype -max abc } -returnCodes { error } -result {Error in constructor: invalid -max: "abc"} test fpixels-2.3 {-min > -max} -constraints tk -body { snit::fpixels subtype -min 10 -max 5 } -returnCodes { error } -result {Error in constructor: -max < -min} test fpixels-3.1 {subtype, no suffix} -constraints tk -body { snit::fpixels subtype subtype validate 5 } -cleanup { subtype destroy } -result {5} test fpixels-3.2 {suffix} -constraints tk -body { snit::fpixels subtype subtype validate 5i } -cleanup { subtype destroy } -result {5i} test fpixels-3.3 {decimal} -constraints tk -body { snit::fpixels subtype subtype validate 5.5 } -cleanup { subtype destroy } -result {5.5} test fpixels-3.4 {invalid} -constraints tk -body { snit::fpixels subtype codecatch {subtype validate 5.5abc} } -cleanup { subtype destroy } -result {INVALID invalid value "5.5abc", expected fpixels} test fpixels-3.5 {subtype -min} -constraints tk -body { snit::fpixels subtype -min 5 subtype validate 10 } -cleanup { subtype destroy } -result {10} test fpixels-3.6 {min of min, max} -constraints tk -body { snit::fpixels subtype -min 5 -max 20 subtype validate 5 } -cleanup { subtype destroy } -result {5} test fpixels-3.7 {max of min, max} -constraints tk -body { snit::fpixels subtype -min 5 -max 20 subtype validate 20 } -cleanup { subtype destroy } -result {20} test fpixels-3.8 {middle of min, max} -constraints tk -body { snit::fpixels subtype -min 5 -max 20 subtype validate 15 } -cleanup { subtype destroy } -result {15} test fpixels-3.9 {invalid, < min} -constraints tk -body { snit::fpixels subtype -min 5 codecatch {subtype validate 4} } -cleanup { subtype destroy } -result {INVALID invalid value "4", expected fpixels no less than 5} test fpixels-3.10 {invalid, > max} -constraints tk -body { snit::fpixels subtype -min 5 -max 20 codecatch {subtype validate 21} } -cleanup { subtype destroy } -result {INVALID invalid value "21", expected fpixels in range 5, 20} test fpixels-3.11 {invalid, > max, range with suffix} -constraints tk -body { snit::fpixels subtype -min 5i -max 10i codecatch {subtype validate 11i} } -cleanup { subtype destroy } -result {INVALID invalid value "11i", expected fpixels in range 5i, 10i} #----------------------------------------------------------------------- # snit::integer test integer-1.1 {integer: invalid -min} -body { snit::integer obj -min abc } -returnCodes { error } -result {Error in constructor: invalid -min: "abc"} test integer-1.2 {integer: invalid -max} -body { snit::integer obj -max abc } -returnCodes { error } -result {Error in constructor: invalid -max: "abc"} test integer-1.3 {integer: invalid, max < min} -body { snit::integer obj -min 5 -max 0 } -returnCodes { error } -result {Error in constructor: -max < -min} test integer-2.1 {integer type: valid} -body { snit::integer validate 1 } -result {1} test integer-2.2 {integer type: invalid} -body { codecatch {snit::integer validate abc} } -result {INVALID invalid value "abc", expected integer} test integer-3.1 {integer subtype: valid, no range} -body { snit::integer subtype subtype validate 1 } -cleanup { subtype destroy } -result {1} test integer-3.2 {integer subtype: valid, min but no max} -body { snit::integer subtype -min 0 subtype validate 1 } -cleanup { subtype destroy } -result {1} test integer-3.3 {integer subtype: valid, min and max} -body { snit::integer subtype -min 0 -max 10 subtype validate 1 } -cleanup { subtype destroy } -result {1} test integer-4.1 {integer subtype: not a number} -body { snit::integer subtype codecatch {subtype validate quux} } -cleanup { subtype destroy } -result {INVALID invalid value "quux", expected integer} test integer-4.2 {integer subtype: less than min, no max} -body { snit::integer subtype -min 0 codecatch {subtype validate -1} } -cleanup { subtype destroy } -result {INVALID invalid value "-1", expected integer no less than 0} test integer-4.3 {integer subtype: less than min, with max} -body { snit::integer subtype -min 0 -max 5 codecatch {subtype validate -1} } -cleanup { subtype destroy } -result {INVALID invalid value "-1", expected integer in range 0, 5} #----------------------------------------------------------------------- # snit::listtype test listtype-1.1 {listtype, length 0; valid} -body { snit::listtype validate "" } -result {} test listtype-1.2 {listtype, length 1; valid} -body { snit::listtype validate a } -result {a} test listtype-1.3 {listtype, length 2; valid} -body { snit::listtype validate {a b} } -result {a b} test listtype-2.1 {listtype subtype, length 0; valid} -body { snit::listtype subtype subtype validate "" } -cleanup { subtype destroy } -result {} test listtype-2.2 {listtype, length 1; valid} -body { snit::listtype subtype subtype validate a } -cleanup { subtype destroy } -result {a} test listtype-2.3 {listtype, length 2; valid} -body { snit::listtype subtype subtype validate {a b} } -cleanup { subtype destroy } -result {a b} test listtype-2.4 {listtype, invalid -minlen} -body { snit::listtype subtype -minlen abc } -returnCodes { error } -result {Error in constructor: invalid -minlen: "abc"} test listtype-2.5 {listtype, negative -minlen} -body { snit::listtype subtype -minlen -1 } -returnCodes { error } -result {Error in constructor: invalid -minlen: "-1"} test listtype-2.6 {listtype, invalid -maxlen} -body { snit::listtype subtype -maxlen abc } -returnCodes { error } -result {Error in constructor: invalid -maxlen: "abc"} test listtype-2.7 {listtype, -maxlen < -minlen} -body { snit::listtype subtype -minlen 10 -maxlen 9 } -returnCodes { error } -result {Error in constructor: -maxlen < -minlen} test listtype-3.1 {-minlen 2, length 2; valid} -body { snit::listtype subtype -minlen 2 subtype validate {a b} } -cleanup { subtype destroy } -result {a b} test listtype-3.2 {-minlen 2, length 3; valid} -body { snit::listtype subtype -minlen 2 subtype validate {a b c} } -cleanup { subtype destroy } -result {a b c} test listtype-3.3 {-minlen 2, length 1; invalid} -body { snit::listtype subtype -minlen 2 codecatch {subtype validate a} } -cleanup { subtype destroy } -result {INVALID value has too few elements; at least 2 expected} test listtype-3.4 {range 1 to 3, length 1; valid} -body { snit::listtype subtype -minlen 1 -maxlen 3 subtype validate a } -cleanup { subtype destroy } -result {a} test listtype-3.5 {range 1 to 3, length 3; valid} -body { snit::listtype subtype -minlen 1 -maxlen 3 subtype validate {a b c} } -cleanup { subtype destroy } -result {a b c} test listtype-3.6 {range 1 to 3, length 0; invalid} -body { snit::listtype subtype -minlen 1 -maxlen 3 codecatch {subtype validate {}} } -cleanup { subtype destroy } -result {INVALID value has too few elements; at least 1 expected} test listtype-3.7 {range 1 to 3, length 4; invalid} -body { snit::listtype subtype -minlen 1 -maxlen 3 codecatch {subtype validate {a b c d}} } -cleanup { subtype destroy } -result {INVALID value has too many elements; no more than 3 expected} test listtype-4.1 {boolean list, valid} -body { snit::listtype subtype -type snit::boolean subtype validate {yes 1 true} } -cleanup { subtype destroy } -result {yes 1 true} test listtype-4.2 {boolean list, invalid} -body { snit::listtype subtype -type snit::boolean codecatch {subtype validate {yes 1 abc no}} } -cleanup { subtype destroy } -result {INVALID invalid boolean "abc", should be one of: 1, 0, true, false, yes, no, on, off} #----------------------------------------------------------------------- # snit::pixels test pixels-1.1 {no suffix} -constraints tk -body { snit::pixels validate 5 } -result {5} test pixels-1.2 {suffix} -constraints tk -body { snit::pixels validate 5i } -result {5i} test pixels-1.3 {decimal} -constraints tk -body { snit::pixels validate 5.5 } -result {5.5} test pixels-1.4 {invalid} -constraints tk -body { codecatch {snit::pixels validate 5.5abc} } -result {INVALID invalid value "5.5abc", expected pixels} test pixels-2.1 {bad -min} -constraints tk -body { snit::pixels subtype -min abc } -returnCodes { error } -result {Error in constructor: invalid -min: "abc"} test pixels-2.2 {bad -max} -constraints tk -body { snit::pixels subtype -max abc } -returnCodes { error } -result {Error in constructor: invalid -max: "abc"} test pixels-2.3 {-min > -max} -constraints tk -body { snit::pixels subtype -min 10 -max 5 } -returnCodes { error } -result {Error in constructor: -max < -min} test pixels-3.1 {subtype, no suffix} -constraints tk -body { snit::pixels subtype subtype validate 5 } -cleanup { subtype destroy } -result {5} test pixels-3.2 {suffix} -constraints tk -body { snit::pixels subtype subtype validate 5i } -cleanup { subtype destroy } -result {5i} test pixels-3.3 {decimal} -constraints tk -body { snit::pixels subtype subtype validate 5.5 } -cleanup { subtype destroy } -result {5.5} test pixels-3.4 {invalid} -constraints tk -body { snit::pixels subtype codecatch {subtype validate 5.5abc} } -cleanup { subtype destroy } -result {INVALID invalid value "5.5abc", expected pixels} test pixels-3.5 {subtype -min} -constraints tk -body { snit::pixels subtype -min 5 subtype validate 10 } -cleanup { subtype destroy } -result {10} test pixels-3.6 {min of min, max} -constraints tk -body { snit::pixels subtype -min 5 -max 20 subtype validate 5 } -cleanup { subtype destroy } -result {5} test pixels-3.7 {max of min, max} -constraints tk -body { snit::pixels subtype -min 5 -max 20 subtype validate 20 } -cleanup { subtype destroy } -result {20} test pixels-3.8 {middle of min, max} -constraints tk -body { snit::pixels subtype -min 5 -max 20 subtype validate 15 } -cleanup { subtype destroy } -result {15} test pixels-3.9 {invalid, < min} -constraints tk -body { snit::pixels subtype -min 5 codecatch {subtype validate 4} } -cleanup { subtype destroy } -result {INVALID invalid value "4", expected pixels no less than 5} test pixels-3.10 {invalid, > max} -constraints tk -body { snit::pixels subtype -min 5 -max 20 codecatch {subtype validate 21} } -cleanup { subtype destroy } -result {INVALID invalid value "21", expected pixels in range 5, 20} test pixels-3.11 {invalid, > max, range with suffix} -constraints tk -body { snit::pixels subtype -min 5i -max 10i codecatch {subtype validate 11i} } -cleanup { subtype destroy } -result {INVALID invalid value "11i", expected pixels in range 5i, 10i} #----------------------------------------------------------------------- # snit::stringtype test stringtype-1.1 {stringtype, valid string} -body { snit::stringtype validate "" } -result {} test stringtype-2.1 {stringtype subtype: invalid -regexp} -body { snit::stringtype subtype -regexp "\[A-Z" } -returnCodes { error } -result {Error in constructor: invalid -regexp: "[A-Z"} test stringtype-2.2 {stringtype subtype: invalid -minlen} -body { snit::stringtype subtype -minlen foo } -returnCodes { error } -result {Error in constructor: invalid -minlen: "foo"} test stringtype-2.3 {stringtype subtype: invalid -maxlen} -body { snit::stringtype subtype -maxlen foo } -returnCodes { error } -result {Error in constructor: invalid -maxlen: "foo"} test stringtype-2.4 {stringtype subtype: -maxlen < -minlen} -body { snit::stringtype subtype -maxlen 1 -minlen 5 } -returnCodes { error } -result {Error in constructor: -maxlen < -minlen} test stringtype-2.5 {stringtype subtype: -minlen < 0} -body { snit::stringtype subtype -minlen -1 } -returnCodes { error } -result {Error in constructor: invalid -minlen: "-1"} test stringtype-2.6 {stringtype subtype: -maxlen < 0} -body { snit::stringtype subtype -maxlen -1 } -returnCodes { error } -result {Error in constructor: -maxlen < -minlen} test stringtype-3.1 {stringtype subtype: -glob, valid} -body { snit::stringtype subtype -glob "*FOO*" subtype validate 1FOO2 } -cleanup { subtype destroy } -result {1FOO2} test stringtype-3.2 {stringtype subtype: -glob, case-insensitive} -body { snit::stringtype subtype -nocase yes -glob "*FOO*" subtype validate 1foo2 } -cleanup { subtype destroy } -result {1foo2} test stringtype-3.3 {stringtype subtype: -glob invalid, case-sensitive} -body { snit::stringtype subtype -glob "*FOO*" codecatch {subtype validate 1foo2} } -cleanup { subtype destroy } -result {INVALID invalid value "1foo2"} test stringtype-5.4 {stringtype subtype: -glob invalid, case-insensitive} -body { snit::stringtype subtype -nocase yes -glob "*FOO*" codecatch {subtype validate bar} } -cleanup { subtype destroy } -result {INVALID invalid value "bar"} test stringtype-5.5 {stringtype subtype: -regexp valid, case-sensitive} -body { snit::stringtype subtype -regexp {^[A-Z]+$} subtype validate FOO } -cleanup { subtype destroy } -result {FOO} test stringtype-5.6 {stringtype subtype: -regexp valid, case-insensitive} -body { snit::stringtype subtype -nocase yes -regexp {^[A-Z]+$} subtype validate foo } -cleanup { subtype destroy } -result {foo} test stringtype-5.7 {stringtype subtype: -regexp invalid, case-sensitive} -body { snit::stringtype subtype -regexp {^[A-Z]+$} codecatch {subtype validate foo} } -cleanup { subtype destroy } -result {INVALID invalid value "foo"} test stringtype-5.8 {stringtype subtype: -regexp invalid, case-insensitive} -body { snit::stringtype subtype -nocase yes -regexp {^[A-Z]+$} codecatch {subtype validate foo1} } -cleanup { subtype destroy } -result {INVALID invalid value "foo1"} #----------------------------------------------------------------------- # snit::window test window-1.1 {window: valid} -constraints tk -body { snit::window validate . } -result {.} test window-1.2 {window: invalid} -constraints tk -body { codecatch {snit::window validate .nonesuch} } -result {INVALID invalid value ".nonesuch", value is not a window} test window-2.1 {window subtype: valid} -constraints tk -body { snit::window subtype subtype validate . } -cleanup { subtype destroy } -result {.} test window-2.2 {window subtype: invalid} -constraints tk -body { snit::window subtype codecatch {subtype validate .nonesuch} } -cleanup { subtype destroy } -result {INVALID invalid value ".nonesuch", value is not a window} #----------------------------------------------------------------------- # option -type specifications test optiontype-1.1 {-type is type object name} -body { type dog { option -akcflag -default no -type snit::boolean } dog create spot # Set -akcflag to a boolean value spot configure -akcflag yes spot configure -akcflag 1 spot configure -akcflag on spot configure -akcflag off # Set -akcflag to an invalid value spot configure -akcflag offf } -returnCodes { error } -cleanup { dog destroy } -result {invalid -akcflag value: invalid boolean "offf", should be one of: 1, 0, true, false, yes, no, on, off} test optiontype-1.2 {-type is type specification} -body { type dog { option -color -default brown \ -type {snit::enum -values {brown black white golden}} } dog create spot # Set -color to a valid value spot configure -color brown spot configure -color black spot configure -color white spot configure -color golden # Set -color to an invalid value spot configure -color green } -returnCodes { error } -cleanup { dog destroy } -result {invalid -color value: invalid value "green", should be one of: brown, black, white, golden} test optiontype-1.3 {-type catches invalid defaults} -body { type dog { option -color -default green \ -type {snit::enum -values {brown black white golden}} } dog spot } -returnCodes { error } -cleanup { dog destroy } -result {Error in constructor: invalid -color default: invalid value "green", should be one of: brown, black, white, golden} #----------------------------------------------------------------------- # Bug Fixes test bug-1.1 {Bug 1161779: destructor can't precede constructor} -body { type dummy { destructor { # No content } constructor {args} { $self configurelist $args } } } -cleanup { rename ::dummy "" } -result ::dummy test bug-2.1 {Bug 1106375: Widget Error on failed object's construction} -constraints { tk } -body { ::snit::widgetadaptor mylabel { delegate method * to hull delegate option * to hull constructor {args} { installhull using label error "simulated error" } } catch {mylabel .lab} result list [info commands .lab] $result } -cleanup { ::mylabel destroy } -result {{} {Error in constructor: simulated error}} test bug-2.2 {Bug 1106375: Widget Error on failed object's construction} -constraints { tk } -body { ::snit::widget myframe { delegate method * to hull delegate option * to hull constructor {args} { error "simulated error" } } catch {myframe .frm} result list [info commands .frm] $result } -cleanup { ::myframe destroy } -result {{} {Error in constructor: simulated error}} test bug-3.1 {Bug 1532791: snit2, snit::widget problem} -constraints { tk } -body { snit::widget mywidget { delegate method * to mylabel delegate option * to mylabel variable mylabel {} } mywidget .mylabel } -cleanup { destroy .mylabel } -result {.mylabel} #--------------------------------------------------------------------- # Clean up rename expect {} testsuiteCleanup tcltk2/inst/tklibs/snit2.3.4/modules.txt0000644000176200001440000000067015017041713017477 0ustar liggesusersSnit Modules ---------------------------------------------------------------------- snit.tcl Loader for Snit 1.x main1.tcl Compiler, runtime for Snit 1.x, Tcl 8.4 and later main1_83.tcl Compiler, runtime for Snit 1.x, Tcl 8.3 snit2.tcl Loader for Snit 2.x main2.tcl Compiler, runtime for Snit 2.x, Tcl 8.5 and later validate.tcl Snit validation types, Snit 1.x *and* Snit 2.x tcltk2/inst/tklibs/snit2.3.4/README.tcl83.txt0000644000176200001440000000466415017041713017727 0ustar liggesusers#-------------------------------------------------------------------------- # README.tcl83.txt #-------------------------------------------------------------------------- # Back-port of Snit to Tcl83 #-------------------------------------------------------------------------- # Copyright # # Copyright (c) 2005 Kenneth Green # All rights reserved #-------------------------------------------------------------------------- # This code is freely distributable, but is provided as-is with # no warranty expressed or implied. #-------------------------------------------------------------------------- # Acknowledgements # 1) The changes described in this file are made to awesome 'snit' # library as provided by William H. Duquette under the terms # defined in the associated 'license.txt'. #-------------------------------------------------------------------------- Snit is pure-Tcl object and megawidget framework. See snit.html for full details. It was written for Tcl/Tk 8.4 but a back-port to Tcl/Tk 8.3 has been done by Kenneth Green (green.kenneth@gmail.com). ----------------------------------------------------------------- The back-port to Tcl 83 passes 100% of the snit.test test cases. It adds two files to the package, this README file plus the back-port utility file: snit_tcl83_utils.tcl. Very few changes were required to either snit.tcl or snit.test to get them to run with Tcl/Tk 8.3. All changes in those files are tagged with a '#kmg' comment. ----------------------------------------------------------------- 07-Jun-2005 kmg (Release 1.0.1) Port of first full snit release 1.0 Passes 452/452 test cases in snit.test Known problems: 1) In some cases that I have not been able to characterise, an instance will be destroyed twice causing an error. If this happens, try wrapping your deletion of the instance in a catch. 2) As a consequence of (1), one test case generates an error in its cleanup phase, even though the test itself passes OK 10-Feb-2005 kmg (Beta Release 0.95.2) Fixed bug in 'namespace' procedure in snit_tcl83_utils.tcl. Made it execute the underlying __namespace__ in the context of the caller's namespace. 28-Aug-2004 kmg (Beta Release 0.95.1) First trial release of the back-port to Tcl/Tk 8.3 Snit will work fine on Tcl/Tk 8.4 but a few of the tests will have to have the changes commented out and the original code uncommented in order to pass. tcltk2/inst/tklibs/snit2.3.4/snit.tcl0000644000176200001440000000136615017041713016752 0ustar liggesusers#----------------------------------------------------------------------- # TITLE: # snit.tcl # # AUTHOR: # Will Duquette # # DESCRIPTION: # Snit's Not Incr Tcl, a simple object system in Pure Tcl. # # Snit 1.x Loader # # Copyright (C) 2003-2006 by William H. Duquette # This code is licensed as described in license.txt. # #----------------------------------------------------------------------- package require Tcl 8.5 9 # Define the snit namespace and save the library directory namespace eval ::snit:: { variable library [file dirname [info script]] } source [file join $::snit::library main1.tcl] # Load the library of Snit validation types. source [file join $::snit::library validate.tcl] package provide snit 1.4.3 tcltk2/inst/tklibs/snit2.3.4/validate.tcl0000644000176200001440000004501715017041713017567 0ustar liggesusers#----------------------------------------------------------------------- # TITLE: # validate.tcl # # AUTHOR: # Will Duquette # # DESCRIPTION: # Snit validation types. # #----------------------------------------------------------------------- namespace eval ::snit:: { namespace export \ boolean \ double \ enum \ fpixels \ integer \ listtype \ pixels \ stringtype \ window } #----------------------------------------------------------------------- # snit::boolean snit::type ::snit::boolean { #------------------------------------------------------------------- # Type Methods typemethod validate {value} { if {![string is boolean -strict $value]} { return -code error -errorcode INVALID \ "invalid boolean \"$value\", should be one of: 1, 0, true, false, yes, no, on, off" } return $value } #------------------------------------------------------------------- # Constructor # None needed; no options #------------------------------------------------------------------- # Public Methods method validate {value} { $type validate $value } } #----------------------------------------------------------------------- # snit::double snit::type ::snit::double { #------------------------------------------------------------------- # Options # -min value # # Minimum value option -min -default "" -readonly 1 # -max value # # Maximum value option -max -default "" -readonly 1 #------------------------------------------------------------------- # Type Methods typemethod validate {value} { if {![string is double -strict $value]} { return -code error -errorcode INVALID \ "invalid value \"$value\", expected double" } return $value } #------------------------------------------------------------------- # Constructor constructor {args} { # FIRST, get the options $self configurelist $args if {"" != $options(-min) && ![string is double -strict $options(-min)]} { return -code error \ "invalid -min: \"$options(-min)\"" } if {"" != $options(-max) && ![string is double -strict $options(-max)]} { return -code error \ "invalid -max: \"$options(-max)\"" } if {"" != $options(-min) && "" != $options(-max) && $options(-max) < $options(-min)} { return -code error "-max < -min" } } #------------------------------------------------------------------- # Public Methods # Fixed method for the snit::double type. # WHD, 6/7/2010. method validate {value} { $type validate $value if {("" != $options(-min) && $value < $options(-min)) || ("" != $options(-max) && $value > $options(-max))} { set msg "invalid value \"$value\", expected double" if {"" != $options(-min) && "" != $options(-max)} { append msg " in range $options(-min), $options(-max)" } elseif {"" != $options(-min)} { append msg " no less than $options(-min)" } elseif {"" != $options(-max)} { append msg " no greater than $options(-max)" } return -code error -errorcode INVALID $msg } return $value } } #----------------------------------------------------------------------- # snit::enum snit::type ::snit::enum { #------------------------------------------------------------------- # Options # -values list # # Valid values for this type option -values -default {} -readonly 1 #------------------------------------------------------------------- # Type Methods typemethod validate {value} { # No -values specified; it's always valid return $value } #------------------------------------------------------------------- # Constructor constructor {args} { $self configurelist $args if {[llength $options(-values)] == 0} { return -code error \ "invalid -values: \"\"" } } #------------------------------------------------------------------- # Public Methods method validate {value} { if {[lsearch -exact $options(-values) $value] == -1} { return -code error -errorcode INVALID \ "invalid value \"$value\", should be one of: [join $options(-values) {, }]" } return $value } } #----------------------------------------------------------------------- # snit::fpixels snit::type ::snit::fpixels { #------------------------------------------------------------------- # Options # -min value # # Minimum value option -min -default "" -readonly 1 # -max value # # Maximum value option -max -default "" -readonly 1 #------------------------------------------------------------------- # Instance variables variable min "" ;# -min, no suffix variable max "" ;# -max, no suffix #------------------------------------------------------------------- # Type Methods typemethod validate {value} { if {[catch {winfo fpixels . $value} dummy]} { return -code error -errorcode INVALID \ "invalid value \"$value\", expected fpixels" } return $value } #------------------------------------------------------------------- # Constructor constructor {args} { # FIRST, get the options $self configurelist $args if {"" != $options(-min) && [catch {winfo fpixels . $options(-min)} min]} { return -code error \ "invalid -min: \"$options(-min)\"" } if {"" != $options(-max) && [catch {winfo fpixels . $options(-max)} max]} { return -code error \ "invalid -max: \"$options(-max)\"" } if {"" != $min && "" != $max && $max < $min} { return -code error "-max < -min" } } #------------------------------------------------------------------- # Public Methods method validate {value} { $type validate $value set val [winfo fpixels . $value] if {("" != $min && $val < $min) || ("" != $max && $val > $max)} { set msg "invalid value \"$value\", expected fpixels" if {"" != $min && "" != $max} { append msg " in range $options(-min), $options(-max)" } elseif {"" != $min} { append msg " no less than $options(-min)" } return -code error -errorcode INVALID $msg } return $value } } #----------------------------------------------------------------------- # snit::integer snit::type ::snit::integer { #------------------------------------------------------------------- # Options # -min value # # Minimum value option -min -default "" -readonly 1 # -max value # # Maximum value option -max -default "" -readonly 1 #------------------------------------------------------------------- # Type Methods typemethod validate {value} { if {![string is integer -strict $value]} { return -code error -errorcode INVALID \ "invalid value \"$value\", expected integer" } return $value } #------------------------------------------------------------------- # Constructor constructor {args} { # FIRST, get the options $self configurelist $args if {"" != $options(-min) && ![string is integer -strict $options(-min)]} { return -code error \ "invalid -min: \"$options(-min)\"" } if {"" != $options(-max) && ![string is integer -strict $options(-max)]} { return -code error \ "invalid -max: \"$options(-max)\"" } if {"" != $options(-min) && "" != $options(-max) && $options(-max) < $options(-min)} { return -code error "-max < -min" } } #------------------------------------------------------------------- # Public Methods method validate {value} { $type validate $value if {("" != $options(-min) && $value < $options(-min)) || ("" != $options(-max) && $value > $options(-max))} { set msg "invalid value \"$value\", expected integer" if {"" != $options(-min) && "" != $options(-max)} { append msg " in range $options(-min), $options(-max)" } elseif {"" != $options(-min)} { append msg " no less than $options(-min)" } return -code error -errorcode INVALID $msg } return $value } } #----------------------------------------------------------------------- # snit::list snit::type ::snit::listtype { #------------------------------------------------------------------- # Options # -type type # # Specifies a value type option -type -readonly 1 # -minlen len # # Minimum list length option -minlen -readonly 1 -default 0 # -maxlen len # # Maximum list length option -maxlen -readonly 1 #------------------------------------------------------------------- # Type Methods typemethod validate {value} { if {[catch {llength $value} result]} { return -code error -errorcode INVALID \ "invalid value \"$value\", expected list" } return $value } #------------------------------------------------------------------- # Constructor constructor {args} { # FIRST, get the options $self configurelist $args if {"" != $options(-minlen) && (![string is integer -strict $options(-minlen)] || $options(-minlen) < 0)} { return -code error \ "invalid -minlen: \"$options(-minlen)\"" } if {"" == $options(-minlen)} { set options(-minlen) 0 } if {"" != $options(-maxlen) && ![string is integer -strict $options(-maxlen)]} { return -code error \ "invalid -maxlen: \"$options(-maxlen)\"" } if {"" != $options(-maxlen) && $options(-maxlen) < $options(-minlen)} { return -code error "-maxlen < -minlen" } } #------------------------------------------------------------------- # Methods method validate {value} { $type validate $value set len [llength $value] if {$len < $options(-minlen)} { return -code error -errorcode INVALID \ "value has too few elements; at least $options(-minlen) expected" } elseif {"" != $options(-maxlen)} { if {$len > $options(-maxlen)} { return -code error -errorcode INVALID \ "value has too many elements; no more than $options(-maxlen) expected" } } # NEXT, check each value if {"" != $options(-type)} { foreach item $value { set cmd $options(-type) lappend cmd validate $item uplevel \#0 $cmd } } return $value } } #----------------------------------------------------------------------- # snit::pixels snit::type ::snit::pixels { #------------------------------------------------------------------- # Options # -min value # # Minimum value option -min -default "" -readonly 1 # -max value # # Maximum value option -max -default "" -readonly 1 #------------------------------------------------------------------- # Instance variables variable min "" ;# -min, no suffix variable max "" ;# -max, no suffix #------------------------------------------------------------------- # Type Methods typemethod validate {value} { if {[catch {winfo pixels . $value} dummy]} { return -code error -errorcode INVALID \ "invalid value \"$value\", expected pixels" } return $value } #------------------------------------------------------------------- # Constructor constructor {args} { # FIRST, get the options $self configurelist $args if {"" != $options(-min) && [catch {winfo pixels . $options(-min)} min]} { return -code error \ "invalid -min: \"$options(-min)\"" } if {"" != $options(-max) && [catch {winfo pixels . $options(-max)} max]} { return -code error \ "invalid -max: \"$options(-max)\"" } if {"" != $min && "" != $max && $max < $min} { return -code error "-max < -min" } } #------------------------------------------------------------------- # Public Methods method validate {value} { $type validate $value set val [winfo pixels . $value] if {("" != $min && $val < $min) || ("" != $max && $val > $max)} { set msg "invalid value \"$value\", expected pixels" if {"" != $min && "" != $max} { append msg " in range $options(-min), $options(-max)" } elseif {"" != $min} { append msg " no less than $options(-min)" } return -code error -errorcode INVALID $msg } return $value } } #----------------------------------------------------------------------- # snit::stringtype snit::type ::snit::stringtype { #------------------------------------------------------------------- # Options # -minlen len # # Minimum list length option -minlen -readonly 1 -default 0 # -maxlen len # # Maximum list length option -maxlen -readonly 1 # -nocase 0|1 # # globs and regexps are case-insensitive if -nocase 1. option -nocase -readonly 1 -default 0 # -glob pattern # # Glob-match pattern, or "" option -glob -readonly 1 # -regexp regexp # # Regular expression to match option -regexp -readonly 1 #------------------------------------------------------------------- # Type Methods typemethod validate {value} { # By default, any string (hence, any Tcl value) is valid. return $value } #------------------------------------------------------------------- # Constructor constructor {args} { # FIRST, get the options $self configurelist $args # NEXT, validate -minlen and -maxlen if {"" != $options(-minlen) && (![string is integer -strict $options(-minlen)] || $options(-minlen) < 0)} { return -code error \ "invalid -minlen: \"$options(-minlen)\"" } if {"" == $options(-minlen)} { set options(-minlen) 0 } if {"" != $options(-maxlen) && ![string is integer -strict $options(-maxlen)]} { return -code error \ "invalid -maxlen: \"$options(-maxlen)\"" } if {"" != $options(-maxlen) && $options(-maxlen) < $options(-minlen)} { return -code error "-maxlen < -minlen" } # NEXT, validate -nocase if {[catch {snit::boolean validate $options(-nocase)} result]} { return -code error "invalid -nocase: $result" } # Validate the glob if {"" != $options(-glob) && [catch {string match $options(-glob) ""} dummy]} { return -code error \ "invalid -glob: \"$options(-glob)\"" } # Validate the regexp if {"" != $options(-regexp) && [catch {regexp $options(-regexp) ""} dummy]} { return -code error \ "invalid -regexp: \"$options(-regexp)\"" } } #------------------------------------------------------------------- # Methods method validate {value} { # Usually we'd call [$type validate $value] here, but # as it's a no-op, don't bother. # FIRST, validate the length. set len [string length $value] if {$len < $options(-minlen)} { return -code error -errorcode INVALID \ "too short: at least $options(-minlen) characters expected" } elseif {"" != $options(-maxlen)} { if {$len > $options(-maxlen)} { return -code error -errorcode INVALID \ "too long: no more than $options(-maxlen) characters expected" } } # NEXT, check the glob match, with or without case. if {"" != $options(-glob)} { if {$options(-nocase)} { set result [string match -nocase $options(-glob) $value] } else { set result [string match $options(-glob) $value] } if {!$result} { return -code error -errorcode INVALID \ "invalid value \"$value\"" } } # NEXT, check regexp match with or without case if {"" != $options(-regexp)} { if {$options(-nocase)} { set result [regexp -nocase -- $options(-regexp) $value] } else { set result [regexp -- $options(-regexp) $value] } if {!$result} { return -code error -errorcode INVALID \ "invalid value \"$value\"" } } return $value } } #----------------------------------------------------------------------- # snit::window snit::type ::snit::window { #------------------------------------------------------------------- # Type Methods typemethod validate {value} { if {![winfo exists $value]} { return -code error -errorcode INVALID \ "invalid value \"$value\", value is not a window" } return $value } #------------------------------------------------------------------- # Constructor # None needed; no options #------------------------------------------------------------------- # Public Methods method validate {value} { $type validate $value } } tcltk2/inst/tklibs/snit2.3.4/license.txt0000644000176200001440000000413715017041713017453 0ustar liggesusersThis software is copyrighted by William H. Duquette. The following terms apply to all files associated with the software unless explicitly disclaimed in individual files. The authors hereby grant permission to use, copy, modify, distribute, and license this software and its documentation for any purpose, provided that existing copyright notices are retained in all copies and that this notice is included verbatim in any distributions. No written agreement, license, or royalty fee is required for any of the authorized uses. Modifications to this software may be copyrighted by their authors and need not follow the licensing terms described here, provided that the new terms are clearly indicated on the first page of each file where they apply. IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. GOVERNMENT USE: If you are acquiring this software on behalf of the U.S. government, the Government shall have only "Restricted Rights" in the software and related documentation as defined in the Federal Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you are acquiring the software on behalf of the Department of Defense, the software shall be classified as "Commercial Computer Software" and the Government shall have only "Restricted Rights" as defined in Clause 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the authors grant the U.S. Government and others acting in its behalf permission to use and distribute the software in accordance with the terms specified in this license. tcltk2/inst/tklibs/snit2.3.4/roadmap.txt0000644000176200001440000001414515017041713017454 0ustar liggesusersThis is a roadmap to the code layout in snit.tcl. Package Definition * package provide * ::snit:: namespace definition; exports Snit commands. Major Variable Definitions (this includes a whole lot of code) * ::snit:: variable definitions: * reservedArgs * prettyStackTrace Not used currently * ::snit::typeTemplate Template code shared by all Snit types. As the type definition is parsed, it produced text that gets inserted into this template; then the template is evaluated as though it were sourced from a normal .tcl file. * Type namespace definition * User's typevariable definitions * Commands for use in type code * alias installhull * alias install * alias typevariable * alias variable * alias mytypevar * alias typevarname Deprecated * alias myvar * alias varname Deprecated * alias myproc * alias codename Deprecated * alias mymethod * alias mytypemethod * alias from * Snit's internal variables * See dictionary.txt * Template Code -- Stuff that gets filled in. * proc Snit_instanceVars Initializes instance variables * proc Snit_typeconstructor * Default Procs -- Stuff that's sometimes replaced. * proc Snit_constructor The default constructor * proc Snit_destructor The default destructor (empty) * %COMPILEDDEFS% * Call the Type Constructor * ::snit::nominalTypeProc Template for the normal type proc. * ::snit::simpleTypeProc Template for the simple type proc. This is used when "-hastypemethods no"; all it does is create instances. * ::snit::nominalInstanceProc Template for the body of the normal instance proc. Supports method caching, delegation, etc. * ::snit::simpleInstanceProc Template for the body of the simple instance proc, used when "-simpledispatch yes". Doesn't support delegation, upvar, hierarchical methods, or exotic return types. * Snit compilation variables * compiler The name of the slave interpreter used to "compile" type definitions * compile Array, accumulates results of "compiling" type definitions * reservedwords List of names that can't be used as macros. Basically, any command defined before the first macro. Compilation Commands * proc ::snit::Comp.Init * proc ::snit::Comp.Compile * proc ::snit::Comp.SaveOptionInfo * proc ::snit::Comp.Define * proc ::snit::Comp.statement.pragma * proc ::snit::Comp.statement.widgetclass * proc ::snit::Comp.statement.hulltype * proc ::snit::Comp.statement.constructor * proc ::snit::Comp.statement.destructor * proc ::snit::Comp.statement.option * proc ::snit::Comp.OptionNameIsValid * proc ::snit::Comp.statement.oncget * proc ::snit::Comp.statement.onconfigure * proc ::snit::Comp.statement.method * proc ::snit::Comp.CheckMethodName * proc ::snit::Comp.statement.typemethod * proc ::snit::Comp.statement.typeconstructor * proc ::snit::Comp.statement.proc * proc ::snit::Comp.statement.typevariable * proc ::snit::Comp.statement.variable * proc ::snit::Comp.statement.typecomponent * proc ::snit::Comp.DefineTypeComponent * proc ::snit::Comp.statement.component * proc ::snit::Comp.DefineComponent * proc ::snit::Comp.statement.delegate * proc ::snit::Comp.DelegatedTypemethod * proc ::snit::Comp.DelegatedMethod * proc ::snit::Comp.DelegatedOption * proc ::snit::Comp.statement.expose Public Commands * proc ::snit::compile * proc ::snit::type * proc ::snit::widgetadaptor * proc ::snit::widget * proc ::snit::typemethod * proc ::snit::method * proc ::snit::macro Utility Commands * proc ::snit::Expand * proc ::snit::Mappend * proc ::snit::CheckArgs * proc ::snit::Contains * proc ::snit::Capitalize * proc ::snit::Listify Snit Runtime Library The commands defined here are used by Snit-generated code at run-time rather than compile time. * Object Creation ** ::snit::RT.type.typemethod.create ** ::snit::RT.widget.typemethod.create ** ::snit::RT.MakeInstanceCommand ** ::snit::RT.InstanceTrace ** ::snit::RT.ConstructInstance ** ::snit::RT.UniqueName ** ::snit::RT.UniqueInstanceNamespace ** ::snit::RT.OptionDbGet * Object Destruction ** ::snit::RT.method.destroy ** ::snit::RT.DestroyObject ** ::snit::RT.RemoveInstanceTrace * Typecomponent Management and Typemethod Caching ** ::snit::RT.TypecomponentTrace ** ::snit::RT.CacheTypemethodCommand * Component Management and Method Caching ** ::snit::RT.Component ** ::snit::RT.ComponentTrace ** ::snit::RT.CacheMethodCommand ** ::snit::RT.LookupMethodCommand ** ::snit::RT.ClearInstanceCaches * Component Installation ** ::snit::RT.installhull ** ::snit::RT.install * Method/Variable Name Qualification ** ::snit::RT.variable ** ::snit::RT.mytypevar ** ::snit::RT.myvar ** ::snit::RT.myproc ** ::snit::RT.codename ** ::snit::RT.mytypemethod ** ::snit::RT.mymethod ** ::snit::RT.CallInstance * Utilities ** ::snit::RT.from * Type Destruction ** ::snit::RT.typemethod.destroy * Option Handling ** ::snit::RT.method.cget ** ::snit::RT.CacheCgetCommand ** ::snit::RT.method.configurelist ** ::snit::RT.CacheConfigureCommand ** ::snit::RT.method.configure ** ::snit::RT.GetOptionDbSpec * Type Introspection ** ::snit::RT.typemethod.info ** ::snit::RT.typemethod.info.typevars ** ::snit::RT.typemethod.info.typemethods ** ::snit::RT.typemethod.info.instances * Instance Introspection ** ::snit::RT.method.info ** ::snit::RT.method.info.type ** ::snit::RT.method.info.typevars ** ::snit::RT.method.info.typemethods ** ::snit::RT.method.info.methods ** ::snit::RT.method.info.vars ** ::snit::RT.method.info.options tcltk2/inst/tklibs/snit2.3.4/snitfaq.man0000644000176200001440000035021615017041713017434 0ustar liggesusers[comment {-*- tcl -*- doctools manpage}] [manpage_begin snitfaq n 2.2] [keywords adaptors] [keywords BWidget] [keywords C++] [keywords class] [keywords {Incr Tcl}] [keywords {mega widget}] [keywords object] [keywords {object oriented}] [keywords widget] [keywords {widget adaptors}] [copyright {2003-2006, by William H. Duquette}] [moddesc {Snit's Not Incr Tcl, OO system}] [titledesc {Snit Frequently Asked Questions}] [category {Programming tools}] [description] [para] [section OVERVIEW] [subsection {What is this document?}] This is an atypical FAQ list, in that few of the questions are frequently asked. Rather, these are the questions I think a newcomer to Snit should be asking. This file is not a complete reference to Snit, however; that information is in the [cmd snit] man page. [subsection {What is Snit?}] Snit is a framework for defining abstract data types and megawidgets in pure Tcl. The name "Snit" stands for "Snit's Not Incr Tcl", signifying that Snit takes a different approach to defining objects than does Incr Tcl, the best known object framework for Tcl. Had I realized that Snit would become at all popular, I'd probably have chosen something else. [para] The primary purpose of Snit is to be [term "object glue"]--to help you compose diverse objects from diverse sources into types and megawidgets with clean, convenient interfaces so that you can more easily build your application. [para] Snit isn't about theoretical purity or minimalist design; it's about being able to do powerful things easily and consistently without having to think about them--so that you can concentrate on building your application. [para] Snit isn't about implementing thousands of nearly identical carefully-specified lightweight thingamajigs--not as individual Snit objects. Traditional Tcl methods will be much faster, and not much more complicated. But Snit [emph is] about implementing a clean interface to manage a collection of thousands of nearly identical carefully-specified lightweight thingamajigs (e.g., think of the text widget and text tags, or the canvas widget and canvas objects). Snit lets you hide the details of just how those thingamajigs are stored--so that you can ignore it, and concentrate on building your application. [para] Snit isn't a way of life, a silver bullet, or the Fountain of Youth. It's just a way of managing complexity--and of managing some of the complexity of managing complexity--so that you can concentrate on building your application. [subsection {What version of Tcl does Snit require?}] Snit 1.3 requires Tcl 8.3 or later; Snit 2.2 requires Tcl 8.5 or later. See [sectref {SNIT VERSIONS}] for the differences between Snit 1.3 and Snit 2.2. [subsection {Where can I download Snit?}] Snit is part of Tcllib, the standard Tcl library, so you might already have it. It's also available at the Snit Home Page, [uri http://www.wjduquette.com/snit]. [subsection {What are Snit's goals?}] [para] [list_begin itemized] [item] A Snit object should be at least as efficient as a hand-coded Tcl object (see [uri http://www.wjduquette.com/tcl/objects.html]). [item] The fact that Snit was used in an object's implementation should be transparent (and irrelevant) to clients of that object. [item] Snit should be able to encapsulate objects from other sources, particularly Tk widgets. [item] Snit megawidgets should be (to the extent possible) indistinguishable in interface from Tk widgets. [item] Snit should be Tclish--that is, rather than trying to emulate C++, Smalltalk, or anything else, it should try to emulate Tcl itself. [item] It should have a simple, easy-to-use, easy-to-remember syntax. [list_end] [subsection {How is Snit different from other OO frameworks?}] Snit is unique among Tcl object systems in that it is based not on inheritance but on delegation. Object systems based on inheritance only allow you to inherit from classes defined using the same system, and that's a shame. In Tcl, an object is anything that acts like an object; it shouldn't matter how the object was implemented. I designed Snit to help me build applications out of the materials at hand; thus, Snit is designed to be able to incorporate and build on any object, whether it's a hand-coded object, a Tk widget, an Incr Tcl object, a BWidget or almost anything else. [para] Note that you can achieve the effect of inheritance using [sectref COMPONENTS] and [sectref "DELEGATION"]--and you can inherit from anything that looks like a Tcl object. [subsection {What can I do with Snit?}] Using Snit, a programmer can: [list_begin itemized] [item] Create abstract data types and Tk megawidgets. [item] Define instance variables, type variables, and Tk-style options. [item] Define constructors, destructors, instance methods, type methods, procs. [item] Assemble a type out of component types. Instance methods and options can be delegated to the component types automatically. [list_end] [section {SNIT VERSIONS}] [subsection {Which version of Snit should I use?}] The current Snit distribution includes two versions, Snit 1.3 and Snit 2.2. The reason that both are included is that Snit 2.2 takes advantage of a number of new features of Tcl 8.5 to improve run-time efficiency; as a side-effect, the ugliness of Snit's error messages and stack traces has been reduced considerably. The cost of using Snit 2.2, of course, is that you must target Tcl 8.5. [para] Snit 1.3, on the other hand, lacks Snit 2.2's optimizations, but requires only Tcl 8.3 and later. [para] In short, if you're targetting Tcl 8.3 or 8.4 you should use Snit 1.3. If you can afford to target Tcl 8.5, you should definitely use Snit 2.2. If you will be targetting both, you can use Snit 1.3 exclusively, or (if your code is unaffected by the minor incompatibilities between the two versions) you can use Snit 1.3 for Tcl 8.4 and Snit 2.2 for Tcl 8.5. [subsection {How do I select the version of Snit I want to use?}] To always use Snit 1.3 (or a later version of Snit 1.x), invoke Snit as follows: [example {package require snit 1.3 }] To always use Snit 2.2 (or a later version of Snit 2.x), say this instead: [example {package require snit 2.2 }] Note that if you request Snit 2.2 explicitly, your application will halt with Tcl 8.4, since Snit 2.2 is unavailable for Tcl 8.4. [para] If you wish your application to always use the latest available version of Snit, don't specify a version number: [example {package require snit }] Tcl will find and load the latest version that's available relative to the version of Tcl being used. In this case, be careful to avoid using any incompatible features. [subsection {How are Snit 1.3 and Snit 2.2 incompatible?}] To the extent possible, Snit 2.2 is intended to be a drop-in replacement for Snit 1.3. Unfortunately, some incompatibilities were inevitable because Snit 2.2 uses Tcl 8.5's new [cmd "namespace ensemble"] mechanism to implement subcommand dispatch. This approach is much faster than the mechanism used in Snit 1.3, and also results in much better error messages; however, it also places new constraints on the implementation. [para] There are four specific incompatibilities between Snit 1.3 and Snit 2.2. [para] [list_begin itemized] [item] Snit 1.3 supports implicit naming of objects. Suppose you define a new [cmd snit::type] called [cmd dog]. You can create instances of [cmd dog] in three ways: [example {dog spot ;# Explicit naming set obj1 [dog %AUTO%] ;# Automatic naming set obj2 [dog] ;# Implicit naming }] In Snit 2.2, type commands are defined using the [cmd "namespace ensemble"] mechanism; and [cmd "namespace ensemble"] doesn't allow an ensemble command to be called without a subcommand. In short, using [cmd "namespace ensemble"] there's no way to support implicit naming. [para] All is not lost, however. If the type has no type methods, then the type command is a simple command rather than an ensemble, and [cmd "namespace ensemble"] is not used. In this case, implicit naming is still possible. [para] In short, you can have implicit naming if you're willing to do without type methods (including the standard type methods, like [cmd "\$type info"]). To do so, use the [const -hastypemethods] pragma: [example {pragma -hastypemethods 0}] [item] Hierarchical methods and type methods are implemented differently in Snit 2.2. [para] A hierarchical method is an instance method which has subcommands; these subcommands are themselves methods. The Tk text widget's [cmd tag] command and its subcommands are examples of hierarchical methods. You can implement such subcommands in Snit simply by including multiple words in the method names: [example {method {tag configure} {tag args} { ... } method {tag cget} {tag option} {...} }] Here we've implicitly defined a [cmd tag] method which has two subcommands, [cmd configure] and [cmd cget]. [para] In Snit 1.3, hierarchical methods could be called in two ways: [example {$obj tag cget -myoption ;# The good way $obj {tag cget} -myoption ;# The weird way }] In the second call, we see that a hierarchical method or type method is simply one whose name contains multiple words. [para] In Snit 2.2 this is no longer the case, and the "weird" way of calling hierarchical methods and type methods no longer works. [item] The third incompatibility derives from the second. In Snit 1.3, hierarchical methods were also simply methods whose name contains multiple words. As a result, [cmd "\$obj info methods"] returned the full names of all hierarchical methods. In the example above, the list returned by [cmd "\$obj info methods"] would include [cmd "tag configure"] and [cmd "tag cget"] but not [cmd "tag"], since [cmd "tag"] is defined only implicitly. [para] In Snit 2.2, hierarchical methods and type methods are no longer simply ones whose name contains multiple words; in the above example, the list returned by [cmd "\$obj info methods"] would include [cmd "tag"] but not [cmd "tag configure"] or [cmd "tag cget"]. [item] The fourth incompatibility is due to a new feature. Snit 2.2 uses the new [cmd "namespace path"] command so that a type's code can call any command defined in the type's parent namespace without qualification or importation. For example, suppose you have a package called [cmd "mypackage"] which defines a number of commands including a type, [cmd "::mypackage::mytype"]. Thanks to [cmd "namespace path"], the type's code can call any of the other commands defined in [cmd "::mypackage::"]. [para] This is extremely convenient. However, it also means that commands defined in the parent namespace, [cmd "::mypackage::"] can block the type's access to identically named commands in the global namespace. This can lead to bugs. For example, Tcllib includes a type called [cmd "::tie::std::file"]. This type's code calls the standard [cmd "file"] command. When run with Snit 2.2, the code broke-- the type's command, [cmd "::tie::std::file"], is itself a command in the type's parent namespace, and so instead of calling the standard [cmd "file"] command, the type found itself calling itself. [list_end] [subsection {Are there other differences between Snit 1.x and Snit 2.2?}] Yes. [list_begin itemized] [item] Method dispatch is considerably faster. [item] Many error messages and stack traces are cleaner. [item] The [const -simpledispatch] pragma is obsolete, and ignored if present. In Snit 1.x, [const -simpledispatch] substitutes a faster mechanism for method dispatch, at the cost of losing certain features. Snit 2.2 method dispatch is faster still in all cases, so [const -simpledispatch] is no longer needed. [item] In Snit 2.2, a type's code (methods, type methods, etc.) can call commands from the type's parent namespace without qualifying or importing them, i.e., type [cmd ::parentns::mytype]'s code can call [cmd ::parentns::someproc] as just [cmd someproc]. [para] This is extremely useful when a type is defined as part of a larger package, and shares a parent namespace with the rest of the package; it means that the type can call other commands defined by the package without any extra work. [para] This feature depends on the new Tcl 8.5 [cmd "namespace path"] command, which is why it hasn't been implemented for V1.x. V1.x code can achieve something similar by placing [example {namespace import [namespace parent]::*}] in a type constructor. This is less useful, however, as it picks up only those commands which have already been exported by the parent namespace at the time the type is defined. [list_end] [section OBJECTS] [subsection {What is an object?}] A full description of object-oriented programming is beyond the scope of this FAQ, obviously. In simple terms, an object is an instance of an abstract data type--a coherent bundle of code and data. There are many ways to represent objects in Tcl/Tk; the best known examples are the Tk widgets. [para] A Tk widget is an object; it is represented by a Tcl command. The object's methods are subcommands of the Tcl command. The object's properties are options accessed using the [method configure] and [method cget] methods. Snit uses the same conventions as Tk widgets do. [subsection {What is an abstract data type?}] In computer science terms, an abstract data type is a complex data structure along with a set of operations--a stack, a queue, a binary tree, etc--that is to say, in modern terms, an object. In systems that include some form of inheritance the word [term class] is usually used instead of [term {abstract data type}], but as Snit doesn't implement inheritance as it's ordinarily understood the older term seems more appropriate. Sometimes this is called [term {object-based}] programming as opposed to object-oriented programming. Note that you can easily create the effect of inheritance using [sectref COMPONENTS] and [sectref "DELEGATION"]. [para] In Snit, as in Tk, a [term type] is a command that creates instances -- objects -- which belong to the type. Most types define some number of [term options] which can be set at creation time, and usually can be changed later. [para] Further, an [term instance] is also a Tcl command--a command that gives access to the operations which are defined for that abstract data type. Conventionally, the operations are defined as subcommands of the instance command. For example, to insert text into a Tk text widget, you use the text widget's [method insert] subcommand: [para] [example { # Create a text widget and insert some text in it. text .mytext -width 80 -height 24 .mytext insert end "Howdy!" }] [para] In this example, [cmd text] is the [term type] command and [cmd .mytext] is the [term instance] command. [para] In Snit, object subcommands are generally called [sectref "INSTANCE METHODS"]. [subsection {What kinds of abstract data types does Snit provide?}] Snit allows you to define three kinds of abstract data type: [para] [list_begin itemized] [item] [cmd snit::type] [item] [cmd snit::widget] [item] [cmd snit::widgetadaptor] [list_end] [subsection {What is a snit::type?}] A [cmd snit::type] is a non-GUI abstract data type, e.g., a stack or a queue. [cmd snit::type]s are defined using the [cmd snit::type] command. For example, if you were designing a kennel management system for a dog breeder, you'd need a dog type. [para] [example {% snit::type dog { # ... } ::dog % }] [para] This definition defines a new command ([cmd ::dog], in this case) that can be used to define dog objects. [para] An instance of a [cmd snit::type] can have [sectref {INSTANCE METHODS}], [sectref {INSTANCE VARIABLES}], [sectref OPTIONS], and [sectref COMPONENTS]. The type itself can have [sectref {TYPE METHODS}], [sectref {TYPE VARIABLES}], [sectref {TYPE COMPONENTS}], and [sectref PROCS]. [subsection {What is a snit::widget?, the short story}] A [cmd snit::widget] is a Tk megawidget built using Snit; it is very similar to a [cmd snit::type]. See [sectref WIDGETS]. [subsection {What is a snit::widgetadaptor?, the short story}] A [cmd snit::widgetadaptor] uses Snit to wrap an existing widget type (e.g., a Tk label), modifying its interface to a lesser or greater extent. It is very similar to a [cmd snit::widget]. See [sectref {WIDGET ADAPTORS}]. [subsection {How do I create an instance of a snit::type?}] You create an instance of a [cmd snit::type] by passing the new instance's name to the type's create method. In the following example, we create a [cmd dog] object called [cmd spot]. [para] [example {% snit::type dog { # .... } ::dog % dog create spot ::spot % }] [para] In general, the [method create] method name can be omitted so long as the instance name doesn't conflict with any defined [sectref {TYPE METHODS}]. (See [sectref {TYPE COMPONENTS}] for the special case in which this doesn't work.) So the following example is identical to the previous example: [para] [example {% snit::type dog { # .... } ::dog % dog spot ::spot % }] [para] This document generally uses the shorter form. [para] If the [cmd dog] type defines [sectref OPTIONS], these can usually be given defaults at creation time: [para] [example {% snit::type dog { option -breed mongrel option -color brown method bark {} { return "$self barks." } } ::dog % dog create spot -breed dalmation -color spotted ::spot % spot cget -breed dalmation % spot cget -color spotted % }] [para] Once created, the instance name now names a new Tcl command that is used to manipulate the object. For example, the following code makes the dog bark: [para] [example {% spot bark ::spot barks. % }] [para] [subsection {How do I refer to an object indirectly?}] Some programmers prefer to save the object name in a variable, and reference it that way. For example, [para] [example {% snit::type dog { ... } ::dog % set d [dog spot -breed dalmation -color spotted] ::spot % $d cget -breed dalmation % $d bark ::spot barks. % }] [para] If you prefer this style, you might prefer to have Snit generate the instance's name automatically. [subsection {How can I generate the object name automatically?}] If you'd like Snit to generate an object name for you, use the [const %AUTO%] keyword as the requested name: [para] [example {% snit::type dog { ... } ::dog % set d [dog %AUTO%] ::dog2 % $d bark ::dog2 barks. % }] [para] The [const %AUTO%] keyword can be embedded in a longer string: [para] [example {% set d [dog obj_%AUTO%] ::obj_dog4 % $d bark ::obj_dog4 barks. % }] [para] [subsection {Can types be renamed?}] Tcl's [cmd rename] command renames other commands. It's a common technique in Tcl to modify an existing command by renaming it and defining a new command with the original name; the new command usually calls the renamed command. [para] [cmd snit::type] commands, however, should never be renamed; to do so breaks the connection between the type and its objects. [subsection {Can objects be renamed?}] Tcl's [cmd rename] command renames other commands. It's a common technique in Tcl to modify an existing command by renaming it and defining a new command with the original name; the new command usually calls the renamed command. [para] All Snit objects (including [term widgets] and [term widgetadaptors]) can be renamed, though this flexibility has some consequences: [para] [list_begin itemized] [item] In an instance method, the implicit argument [var self] will always contain the object's current name, so instance methods can always call other instance methods using [var \$self]. [item] If the object is renamed, however, then [var \$self]'s value will change. Therefore, don't use [var \$self] for anything that will break if [var \$self] changes. For example, don't pass a callback command to another object like this: [example { .btn configure -command [list $self ButtonPress] }] You'll get an error if [cmd .btn] calls your command after your object is renamed. [item] Instead, your object should define its callback command like this: [example { .btn configure -command [mymethod ButtonPress] }] The [cmd mymethod] command returns code that will call the desired method safely; the caller of the callback can add additional arguments to the end of the command as usual. [item] Every object has a private namespace; the name of this namespace is available in method bodies, etc., as the value of the implicit argument [var selfns]. This value is constant for the life of the object. Use [var \$selfns] instead of [var \$self] if you need a unique token to identify the object. [item] When a [cmd snit::widget]'s instance command is renamed, its Tk window name remains the same -- and is still extremely important. Consequently, the Tk window name is available in method bodies as the value of the implicit argument [var win]. This value is constant for the life of the object. When creating child windows, it's best to use [var {$win.child}] rather than [var {$self.child}] as the name of the child window. [list_end] [subsection {How do I destroy a Snit object?}] Any Snit object of any type can be destroyed by renaming it to the empty string using the Tcl [cmd rename] command. [para] Snit megawidgets (i.e., instances of [cmd snit::widget] and [cmd snit::widgetadaptor]) can be destroyed like any other widget: by using the Tk [cmd destroy] command on the widget or on one of its ancestors in the window hierarchy. [para] Every instance of a [cmd snit::type] has a [method destroy] method: [para] [example {% snit::type dog { ... } ::dog % dog spot ::spot % spot bark ::spot barks. % spot destroy % spot barks invalid command name "spot" % }] [para] Finally, every Snit type has a type method called [method destroy]; calling it destroys the type and all of its instances: [example {% snit::type dog { ... } ::dog % dog spot ::spot % spot bark ::spot barks. % dog destroy % spot bark invalid command name "spot" % dog fido invalid command name "dog" % }] [section {INSTANCE METHODS}] [subsection {What is an instance method?}] An instance method is a procedure associated with a specific object and called as a subcommand of the object's command. It is given free access to all of the object's type variables, instance variables, and so forth. [subsection {How do I define an instance method?}] Instance methods are defined in the type definition using the [cmd method] statement. Consider the following code that might be used to add dogs to a computer simulation: [para] [example {% snit::type dog { method bark {} { return "$self barks." } method chase {thing} { return "$self chases $thing." } } ::dog % }] [para] A dog can bark, and it can chase things. [para] The [cmd method] statement looks just like a normal Tcl [cmd proc], except that it appears in a [cmd snit::type] definition. Notice that every instance method gets an implicit argument called [var self]; this argument contains the object's name. (There's more on implicit method arguments below.) [subsection {How does a client call an instance method?}] The method name becomes a subcommand of the object. For example, let's put a simulated dog through its paces: [para] [example {% dog spot ::spot % spot bark ::spot barks. % spot chase cat ::spot chases cat. % }] [para] [subsection {How does an instance method call another instance method?}] If method A needs to call method B on the same object, it does so just as a client does: it calls method B as a subcommand of the object itself, using the object name stored in the implicit argument [var self]. [para] Suppose, for example, that our dogs never chase anything without barking at them: [para] [example {% snit::type dog { method bark {} { return "$self barks." } method chase {thing} { return "$self chases $thing. [$self bark]" } } ::dog % dog spot ::spot % spot bark ::spot barks. % spot chase cat ::spot chases cat. ::spot barks. % }] [para] [subsection {Are there any limitations on instance method names?}] Not really, so long as you avoid the standard instance method names: [method configure], [method configurelist], [method cget], [method destroy], and [method info]. Also, method names consisting of multiple words define hierarchical methods. [subsection {What is a hierarchical method?}] An object's methods are subcommands of the object's instance command. Hierarchical methods allow an object's methods to have subcommands of their own; and these can in turn have subcommands, and so on. This allows the programmer to define a tree-shaped command structure, such as is used by many of the Tk widgets--the subcommands of the Tk [cmd text] widget's [cmd tag] method are hierarchical methods. [subsection {How do I define a hierarchical method?}] Define methods whose names consist of multiple words. These words define the hierarchy implicitly. For example, the following code defines a [cmd tag] method with subcommands [cmd cget] and [cmd configure]: [example {snit::widget mytext { method {tag configure} {tag args} { ... } method {tag cget} {tag option} {...} } }] Note that there is no explicit definition for the [cmd tag] method; it is implicit in the definition of [cmd "tag configure"] and [cmd "tag cget"]. If you tried to define [cmd tag] explicitly in this example, you'd get an error. [subsection {How do I call hierarchical methods?}] As subcommands of subcommands. [example {% mytext .text .text % .text tag configure redtext -foreground red -background black % .text tag cget redtext -foreground red % }] [subsection {How do I make an instance method private?}] It's often useful to define private methods, that is, instance methods intended to be called only by other methods of the same object. [para] Snit doesn't implement any access control on instance methods, so all methods are [emph {de facto}] public. Conventionally, though, the names of public methods begin with a lower-case letter, and the names of private methods begin with an upper-case letter. [para] For example, suppose our simulated dogs only bark in response to other stimuli; they never bark just for fun. So the [method bark] method becomes [method Bark] to indicate that it is private: [para] [example {% snit::type dog { # Private by convention: begins with uppercase letter. method Bark {} { return "$self barks." } method chase {thing} { return "$self chases $thing. [$self Bark]" } } ::dog % dog fido ::fido % fido chase cat ::fido chases cat. ::fido barks. % }] [para] [subsection {Are there any limitations on instance method arguments?}] Method argument lists are defined just like normal Tcl [cmd proc] argument lists; in particular, they can include arguments with default values and the [var args] argument. [para] However, every method also has a number of implicit arguments provided by Snit in addition to those explicitly defined. The names of these implicit arguments may not used to name explicit arguments. [subsection {What implicit arguments are passed to each instance method?}] The arguments implicitly passed to every method are [var type], [var selfns], [var win], and [var self]. [subsection {What is $type?}] The implicit argument [var type] contains the fully qualified name of the object's type: [para] [example {% snit::type thing { method mytype {} { return $type } } ::thing % thing something ::something % something mytype ::thing % }] [para] [subsection {What is $self?}] The implicit argument [var self] contains the object's fully qualified name. [para] If the object's command is renamed, then [var \$self] will change to match in subsequent calls. Thus, your code should not assume that [var \$self] is constant unless you know for sure that the object will never be renamed. [para] [example {% snit::type thing { method myself {} { return $self } } ::thing % thing mutt ::mutt % mutt myself ::mutt % rename mutt jeff % jeff myself ::jeff % }] [para] [subsection {What is $selfns?}] Each Snit object has a private namespace in which to store its [sectref {INSTANCE VARIABLES}] and [sectref OPTIONS]. The implicit argument [var selfns] contains the name of this namespace; its value never changes, and is constant for the life of the object, even if the object's name changes: [para] [example {% snit::type thing { method myNameSpace {} { return $selfns } } ::thing % thing jeff ::jeff % jeff myNameSpace ::thing::Snit_inst3 % rename jeff mutt % mutt myNameSpace ::thing::Snit_inst3 % }] [para] The above example reveals how Snit names an instance's private namespace; however, you should not write code that depends on the specific naming convention, as it might change in future releases. [subsection {What is $win?}] The implicit argument [var win] is defined for all Snit methods, though it really makes sense only for those of [sectref WIDGETS] and [sectref {WIDGET ADAPTORS}]. [var \$win] is simply the original name of the object, whether it's been renamed or not. For widgets and widgetadaptors, it is also therefore the name of a Tk window. [para] When a [cmd snit::widgetadaptor] is used to modify the interface of a widget or megawidget, it must rename the widget's original command and replace it with its own. [para] Thus, using [var win] whenever the Tk window name is called for means that a [cmd snit::widget] or [cmd snit::widgetadaptor] can be adapted by a [cmd snit::widgetadaptor]. See [sectref WIDGETS] for more information. [subsection {How do I pass an instance method as a callback?}] It depends on the context. [para] Suppose in my application I have a [cmd dog] object named [cmd fido], and I want [cmd fido] to bark when a Tk button called [cmd .bark] is pressed. In this case, I create the callback command in the usual way, using [cmd list]: [para] [example { button .bark -text "Bark!" -command [list fido bark] }] [para] In typical Tcl style, we use a callback to hook two independent components together. But suppose that the [cmd dog] object has a graphical interface and owns the button itself? In this case, the [cmd dog] must pass one of its own instance methods to the button it owns. The obvious thing to do is this: [para] [example {% snit::widget dog { constructor {args} { #... button $win.barkbtn -text "Bark!" -command [list $self bark] #... } } ::dog % }] [para] (Note that in this example, our [cmd dog] becomes a [cmd snit::widget], because it has GUI behavior. See [sectref WIDGETS] for more.) Thus, if we create a [cmd dog] called [cmd .spot], it will create a Tk button called [cmd .spot.barkbtn]; when pressed, the button will call [cmd {$self bark}]. [para] Now, this will work--provided that [cmd .spot] is never renamed to something else. But surely renaming widgets is abnormal? And so it is--unless [cmd .spot] is the hull component of a [cmd snit::widgetadaptor]. If it is, then it will be renamed, and [cmd .spot] will become the name of the [cmd snit::widgetadaptor] object. When the button is pressed, the command [cmd {$self bark}] will be handled by the [cmd snit::widgetadaptor], which might or might not do the right thing. [para] There's a safer way to do it, and it looks like this: [para] [example {% snit::widget dog { constructor {args} { #... button $win.barkbtn -text "Bark!" -command [mymethod bark] #... } } ::dog % }] [para] The command [cmd mymethod] takes any number of arguments, and can be used like [cmd list] to build up a callback command; the only difference is that [cmd mymethod] returns a form of the command that won't change even if the instance's name changes. [para] On the other hand, you might prefer to allow a widgetadaptor to override a method such that your renamed widget will call the widgetadaptor's method instead of its own. In this case, using [cmd "\[list \$self bark\]"] will do what you want...but this is a technique which should be used only in carefully controlled circumstances. [subsection {How do I delegate instance methods to a component?}] See [sectref DELEGATION]. [section {INSTANCE VARIABLES}] [subsection {What is an instance variable?}] An instance variable is a private variable associated with some particular Snit object. Instance variables can be scalars or arrays. [subsection {How is a scalar instance variable defined?}] Scalar instance variables are defined in the type definition using the [cmd variable] statement. You can simply name it, or you can initialize it with a value: [para] [example {snit::type mytype { # Define variable "greeting" and initialize it with "Howdy!" variable greeting "Howdy!" } }] [para] [subsection {How is an array instance variable defined?}] Array instance variables are also defined in the type definition using the [cmd variable] command. You can initialize them at the same time by specifying the [const -array] option: [para] [example {snit::type mytype { # Define array variable "greetings" variable greetings -array { formal "Good Evening" casual "Howdy!" } } }] [para] [subsection {What happens if I don't initialize an instance variable?}] Variables do not really exist until they are given values. If you do not initialize a variable when you define it, then you must be sure to assign a value to it (in the constructor, say, or in some method) before you reference it. [subsection {Are there any limitations on instance variable names?}] Just a few. [para] First, every Snit object has a built-in instance variable called [var options], which should never be redefined. [para] Second, all names beginning with "Snit_" are reserved for use by Snit internal code. [para] Third, instance variable names containing the namespace delimiter ([const ::]) are likely to cause great confusion. [subsection {Do I need to declare my instance variables in my methods?}] No. Once you've defined an instance variable in the type definition, it can be used in any instance code (instance methods, the constructor, and the destructor) without declaration. This differs from normal Tcl practice, in which all non-local variables in a proc need to be declared. [para] There is a speed penalty to having all instance variables implicitly available in all instance code. Even though your code need not declare the variables explicitly, Snit must still declare them, and that takes time. If you have ten instance variables, a method that uses none of them must still pay the declaration penalty for all ten. In most cases, the additional runtime cost is negligible. If extreme cases, you might wish to avoid it; there are two methods for doing so. [para] The first is to define a single instance variable, an array, and store all of your instance data in the array. This way, you're only paying the declaration penalty for one variable--and you probably need the variable most of the time anyway. This method breaks down if your instance variables include multiple arrays; in Tcl 8.5, however, the [cmd dict] command might come to your rescue. [para] The second method is to declare your instance variables explicitly in your instance code, while [emph not] including them in the type definition: [example {snit::type dog { constructor {} { variable mood set mood happy } method setmood {newMood} { variable mood set mood $newMood } method getmood {} { variable mood return $mood } } }] This allows you to ensure that only the required variables are included in each method, at the cost of longer code and run-time errors when you forget to declare a variable you need. [subsection {How do I pass an instance variable's name to another object?}] In Tk, it's common to pass a widget a variable name; for example, Tk label widgets have a [option -textvariable] option which names the variable which will contain the widget's text. This allows the program to update the label's value just by assigning a new value to the variable. [para] If you naively pass the instance variable name to the label widget, you'll be confused by the result; Tk will assume that the name names a global variable. Instead, you need to provide a fully-qualified variable name. From within an instance method or a constructor, you can fully qualify the variable's name using the [cmd myvar] command: [para] [example {snit::widget mywidget { variable labeltext "" constructor {args} { # ... label $win.label -textvariable [myvar labeltext] # ... } } }] [para] [subsection {How do I make an instance variable public?}] Practically speaking, you don't. Instead, you'll implement public variables as [sectref OPTIONS]. Alternatively, you can write [sectref {INSTANCE METHODS}] to set and get the variable's value. [section OPTIONS] [subsection {What is an option?}] A type's options are the equivalent of what other object-oriented languages would call public member variables or properties: they are data values which can be retrieved and (usually) set by the clients of an object. [para] Snit's implementation of options follows the Tk model fairly exactly, except that [cmd snit::type] objects usually don't interact with [sectref "THE TK OPTION DATABASE"]; [cmd snit::widget] and [cmd snit::widgetadaptor] objects, on the other hand, always do. [subsection {How do I define an option?}] Options are defined in the type definition using the [cmd option] statement. Consider the following type, to be used in an application that manages a list of dogs for a pet store: [para] [example {snit::type dog { option -breed -default mongrel option -color -default brown option -akc -default 0 option -shots -default 0 } }] [para] According to this, a dog has four notable properties: a breed, a color, a flag that says whether it's pedigreed with the American Kennel Club, and another flag that says whether it has had its shots. The default dog, evidently, is a brown mutt. [para] There are a number of options you can specify when defining an option; if [const -default] is the only one, you can omit the word [const -default] as follows: [para] [example {snit::type dog { option -breed mongrel option -color brown option -akc 0 option -shots 0 } }] [para] If no [const -default] value is specified, the option's default value will be the empty string (but see [sectref {THE TK OPTION DATABASE}]). [para] The Snit man page refers to options like these as "locally defined" options. [subsection {How can a client set options at object creation?}] The normal convention is that the client may pass any number of options and their values after the object's name at object creation. For example, the [cmd ::dog] command defined in the previous answer can now be used to create individual dogs. Any or all of the options may be set at creation time. [para] [example {% dog spot -breed beagle -color "mottled" -akc 1 -shots 1 ::spot % dog fido -shots 1 ::fido % }] [para] So [cmd ::spot] is a pedigreed beagle; [cmd ::fido] is a typical mutt, but his owners evidently take care of him, because he's had his shots. [para] [emph Note:] If the type defines a constructor, it can specify a different object-creation syntax. See [sectref CONSTRUCTORS] for more information. [subsection {How can a client retrieve an option's value?}] Retrieve option values using the [method cget] method: [para] [example {% spot cget -color mottled % fido cget -breed mongrel % }] [para] [subsection {How can a client set options after object creation?}] Any number of options may be set at one time using the [method configure] instance method. Suppose that closer inspection shows that ::fido is not a brown mongrel, but rather a rare Arctic Boar Hound of a lovely dun color: [para] [example {% fido configure -color dun -breed "Arctic Boar Hound" % fido cget -color dun % fido cget -breed Arctic Boar Hound }] [para] Alternatively, the [method configurelist] method takes a list of options and values; occasionally this is more convenient: [para] [example {% set features [list -color dun -breed "Arctic Boar Hound"] -color dun -breed {Arctic Boar Hound} % fido configurelist $features % fido cget -color dun % fido cget -breed Arctic Boar Hound % }] [para] In Tcl 8.5, the [cmd {*}] keyword can be used with [method configure] in this case: [para] [example {% set features [list -color dun -breed "Arctic Boar Hound"] -color dun -breed {Arctic Boar Hound} % fido configure {*}$features % fido cget -color dun % fido cget -breed Arctic Boar Hound % }] [para] The results are the same. [subsection {How should an instance method access an option value?}] There are two ways an instance method can set and retrieve an option's value. One is to use the [method configure] and [method cget] methods, as shown below. [para] [example {% snit::type dog { option -weight 10 method gainWeight {} { set wt [$self cget -weight] incr wt $self configure -weight $wt } } ::dog % dog fido ::fido % fido cget -weight 10 % fido gainWeight % fido cget -weight 11 % }] [para] Alternatively, Snit provides a built-in array instance variable called [var options]. The indices are the option names; the values are the option values. The method [method gainWeight] can thus be rewritten as follows: [para] [example { method gainWeight {} { incr options(-weight) } }] [para] As you can see, using the [var options] variable involves considerably less typing and is the usual way to do it. But if you use [const -configuremethod] or [const -cgetmethod] (described in the following answers), you might wish to use the [method configure] and [method cget] methods anyway, just so that any special processing you've implemented is sure to get done. Also, if the option is delegated to a component then [method configure] and [method cget] are the only way to access it without accessing the component directly. See [sectref "DELEGATION"] for more information. [subsection {How can I make an option read-only?}] Define the option with [const "-readonly yes"]. [para] Suppose you've got an option that determines how instances of your type are constructed; it must be set at creation time, after which it's constant. For example, a dog never changes its breed; it might or might not have had its shots, and if not can have them at a later time. [const -breed] should be read-only, but [const -shots] should not be. [para] [example {% snit::type dog { option -breed -default mongrel -readonly yes option -shots -default no } ::dog % dog fido -breed retriever ::fido % fido configure -shots yes % fido configure -breed terrier option -breed can only be set at instance creation % }] [para] [subsection {How can I catch accesses to an option's value?}] Define a [const -cgetmethod] for the option. [subsection {What is a -cgetmethod?}] A [const -cgetmethod] is a method that's called whenever the related option's value is queried via the [method cget] instance method. The handler can compute the option's value, retrieve it from a database, or do anything else you'd like it to do. [para] Here's what the default behavior would look like if written using a [const -cgetmethod]: [para] [example {snit::type dog { option -color -default brown -cgetmethod GetOption method GetOption {option} { return $options($option) } } }] [para] Any instance method can be used, provided that it takes one argument, the name of the option whose value is to be retrieved. [subsection {How can I catch changes to an option's value?}] Define a [const -configuremethod] for the option. [subsection {What is a -configuremethod?}] A [const -configuremethod] is a method that's called whenever the related option is given a new value via the [method configure] or [method configurelist] instance methods. The method can pass the value on to some other object, store it in a database, or do anything else you'd like it to do. [para] Here's what the default configuration behavior would look like if written using a [const -configuremethod]: [para] [example {snit::type dog { option -color -default brown -configuremethod SetOption method SetOption {option value} { set options($option) $value } } }] [para] Any instance method can be used, provided that it takes two arguments, the name of the option and the new value. [para] Note that if your method doesn't store the value in the [var options] array, the [var options] array won't get updated. [subsection {How can I validate an option's value?}] Define a [const -validatemethod]. [subsection {What is a -validatemethod?}] A [const -validatemethod] is a method that's called whenever the related option is given a new value via the [method configure] or [method configurelist] instance methods. It's the method's responsibility to determine whether the new value is valid, and throw an error if it isn't. The [const -validatemethod], if any, is called before the value is stored in the [var options] array; in particular, it's called before the [const -configuremethod], if any. [para] For example, suppose an option always takes a Boolean value. You can ensure that the value is in fact a valid Boolean like this: [example {% snit::type dog { option -shots -default no -validatemethod BooleanOption method BooleanOption {option value} { if {![string is boolean -strict $value]} { error "expected a boolean value, got \"$value\"" } } } ::dog % dog fido % fido configure -shots yes % fido configure -shots NotABooleanValue expected a boolean value, got "NotABooleanValue" % }] Note that the same [const -validatemethod] can be used to validate any number of boolean options. [para] Any method can be a [const -validatemethod] provided that it takes two arguments, the option name and the new option value. [section {TYPE VARIABLES}] [subsection {What is a type variable?}] A type variable is a private variable associated with a Snit type rather than with a particular instance of the type. In C++ and Java, the term [term "static member variable"] is used for the same notion. Type variables can be scalars or arrays. [subsection {How is a scalar type variable defined?}] Scalar type variables are defined in the type definition using the [cmd typevariable] statement. You can simply name it, or you can initialize it with a value: [para] [example { snit::type mytype { # Define variable "greeting" and initialize it with "Howdy!" typevariable greeting "Howdy!" } }] [para] Every object of type [cmd mytype] now has access to a single variable called [var greeting]. [subsection {How is an array-valued type variable defined?}] Array-valued type variables are also defined using the [cmd typevariable] command; to initialize them, include the [const -array] option: [para] [example {snit::type mytype { # Define typearray variable "greetings" typevariable greetings -array { formal "Good Evening" casual "Howdy!" } } }] [para] [subsection {What happens if I don't initialize a type variable?}] Variables do not really exist until they are given values. If you do not initialize a variable when you define it, then you must be sure to assign a value to it (in the type constructor, say) before you reference it. [subsection {Are there any limitations on type variable names?}] Type variable names have the same restrictions as the names of [sectref {INSTANCE VARIABLES}] do. [subsection {Do I need to declare my type variables in my methods?}] No. Once you've defined a type variable in the type definition, it can be used in [sectref {INSTANCE METHODS}] or [sectref {TYPE METHODS}] without declaration. This differs from normal Tcl practice, in which all non-local variables in a proc need to be declared. [para] Type variables are subject to the same speed/readability tradeoffs as instance variables; see [sectref {Do I need to declare my instance variables in my methods?}] [subsection {How do I pass a type variable's name to another object?}] In Tk, it's common to pass a widget a variable name; for example, Tk label widgets have a [option -textvariable] option which names the variable which will contain the widget's text. This allows the program to update the label's value just by assigning a new value to the variable. [para] If you naively pass a type variable name to the label widget, you'll be confused by the result; Tk will assume that the name names a global variable. Instead, you need to provide a fully-qualified variable name. From within an instance method or a constructor, you can fully qualify the type variable's name using the [cmd mytypevar] command: [para] [example {snit::widget mywidget { typevariable labeltext "" constructor {args} { # ... label $win.label -textvariable [mytypevar labeltext] # ... } } }] [para] [subsection {How do I make a type variable public?}] There are two ways to do this. The preferred way is to write a pair of [sectref {TYPE METHODS}] to set and query the type variable's value. [para] Type variables are stored in the type's namespace, which has the same name as the type itself. Thus, you can also publicize the type variable's name in your documentation so that clients can access it directly. For example, [para] [example {snit::type mytype { typevariable myvariable } set ::mytype::myvariable "New Value" }] [para] [section {TYPE METHODS}] [subsection {What is a type method?}] A type method is a procedure associated with the type itself rather than with any specific instance of the type, and called as a subcommand of the type command. [subsection {How do I define a type method?}] Type methods are defined in the type definition using the [cmd typemethod] statement: [para] [example {snit::type dog { # List of pedigreed dogs typevariable pedigreed typemethod pedigreedDogs {} { return $pedigreed } } }] [para] Suppose the [cmd dog] type maintains a list of the names of the dogs that have pedigrees. The [cmd pedigreedDogs] type method returns this list. [para] The [cmd typemethod] statement looks just like a normal Tcl [cmd proc], except that it appears in a [cmd snit::type] definition. Notice that every type method gets an implicit argument called [var type], which contains the fully-qualified type name. [subsection {How does a client call a type method?}] The type method name becomes a subcommand of the type's command. For example, assuming that the constructor adds each pedigreed dog to the list of [var pedigreedDogs], [para] [example {snit::type dog { option -pedigreed 0 # List of pedigreed dogs typevariable pedigreed typemethod pedigreedDogs {} { return $pedigreed } # ... } dog spot -pedigreed 1 dog fido foreach dog [dog pedigreedDogs] { ... } }] [para] [subsection {Are there any limitations on type method names?}] Not really, so long as you avoid the standard type method names: [method create], [method destroy], and [method info]. [subsection {How do I make a type method private?}] It's sometimes useful to define private type methods, that is, type methods intended to be called only by other type or instance methods of the same object. [para] Snit doesn't implement any access control on type methods; by convention, the names of public methods begin with a lower-case letter, and the names of private methods begin with an upper-case letter. [para] Alternatively, a Snit [cmd proc] can be used as a private type method; see [sectref PROCS]. [subsection {Are there any limitations on type method arguments?}] Method argument lists are defined just like normal Tcl proc argument lists; in particular, they can include arguments with default values and the [var args] argument. [para] However, every type method is called with an implicit argument called [var type] that contains the name of the type command. In addition, type methods should by convention avoid using the names of the arguments implicitly defined for [sectref {INSTANCE METHODS}]. [subsection {How does an instance or type method call a type method?}] If an instance or type method needs to call a type method, it should use [var \$type] to do so: [para] [example {snit::type dog { typemethod pedigreedDogs {} { ... } typemethod printPedigrees {} { foreach obj [$type pedigreedDogs] { ... } } } }] [para] [subsection {How do I pass a type method as a callback?}] It's common in Tcl to pass a snippet of code to another object, for it to call later. Because types cannot be renamed, you can just use the type name, or, if the callback is registered from within a type method, [var type]. For example, suppose we want to print a list of pedigreed dogs when a Tk button is pushed: [para] [example { button .btn -text "Pedigrees" -command [list dog printPedigrees] pack .btn }] Alternatively, from a method or type method you can use the [cmd mytypemethod] command, just as you would use [cmd mymethod] to define a callback command for [sectref {INSTANCE METHODS}]. [subsection {Can type methods be hierarchical?}] Yes, you can define hierarchical type methods in just the same way as you can define hierarchical instance methods. See [sectref {INSTANCE METHODS}] for more. [section PROCS] [subsection {What is a proc?}] A Snit [cmd proc] is really just a Tcl proc defined within the type's namespace. You can use procs for private code that isn't related to any particular instance. [subsection {How do I define a proc?}] Procs are defined by including a [cmd proc] statement in the type definition: [para] [example {snit::type mytype { # Pops and returns the first item from the list stored in the # listvar, updating the listvar proc pop {listvar} { ... } # ... } }] [para] [subsection {Are there any limitations on proc names?}] Any name can be used, so long as it does not begin with [const Snit_]; names beginning with [const Snit_] are reserved for Snit's own use. However, the wise programmer will avoid [cmd proc] names ([cmd set], [cmd list], [cmd if], etc.) that would shadow standard Tcl command names. [para] [cmd proc] names, being private, should begin with a capital letter according to convention; however, as there are typically no public [cmd proc]s in the type's namespace it doesn't matter much either way. [subsection {How does a method call a proc?}] Just like it calls any Tcl command. For example, [para] [example {snit::type mytype { # Pops and returns the first item from the list stored in the # listvar, updating the listvar proc pop {listvar} { ... } variable requestQueue {} # Get one request from the queue and process it. method processRequest {} { set req [pop requestQueue] } } }] [para] [subsection {How can I pass a proc to another object as a callback?}] The [cmd myproc] command returns a callback command for the [cmd proc], just as [cmd mymethod] does for a method. [section {TYPE CONSTRUCTORS}] [subsection {What is a type constructor?}] A type constructor is a body of code that initializes the type as a whole, rather like a C++ static initializer. The body of a type constructor is executed once when the type is defined, and never again. [para] A type can have at most one type constructor. [subsection {How do I define a type constructor?}] A type constructor is defined by using the [cmd typeconstructor] statement in the type definition. For example, suppose the type uses an array-valued type variable as a look-up table, and the values in the array have to be computed at start-up. [para] [example {% snit::type mytype { typevariable lookupTable typeconstructor { array set lookupTable {key value...} } } }] [para] [section CONSTRUCTORS] [subsection {What is a constructor?}] In object-oriented programming, an object's constructor is responsible for initializing the object completely at creation time. The constructor receives the list of options passed to the [cmd snit::type] command's [method create] method and can then do whatever it likes. That might include computing instance variable values, reading data from files, creating other objects, updating type and instance variables, and so forth. [para] The constructor's return value is ignored (unless it's an error, of course). [subsection {How do I define a constructor?}] A constructor is defined by using the [cmd constructor] statement in the type definition. Suppose that it's desired to keep a list of all pedigreed dogs. The list can be maintained in a type variable and retrieved by a type method. Whenever a dog is created, it can add itself to the list--provided that it's registered with the American Kennel Club. [para] [example {% snit::type dog { option -akc 0 typevariable akcList {} constructor {args} { $self configurelist $args if {$options(-akc)} { lappend akcList $self } } typemethod akclist {} { return $akcList } } ::dog % dog spot -akc 1 ::spot % dog fido ::fido % dog akclist ::spot % }] [para] [subsection {What does the default constructor do?}] If you don't provide a constructor explicitly, you get the default constructor, which is identical to the explicitly-defined constructor shown here: [para] [example {snit::type dog { constructor {args} { $self configurelist $args } } }] [para] When the constructor is called, [var args] will be set to the list of arguments that follow the object's name. The constructor is allowed to interpret this list any way it chooses; the normal convention is to assume that it's a list of option names and values, as shown in the example above. If you simply want to save the option values, you should use the [method configurelist] method, as shown. [subsection {Can I choose a different set of arguments for the constructor?}] Yes, you can. For example, suppose we wanted to be sure that the breed was explicitly stated for every dog at creation time, and couldn't be changed thereafter. One way to do that is as follows: [para] [example {% snit::type dog { variable breed option -color brown option -akc 0 constructor {theBreed args} { set breed $theBreed $self configurelist $args } method breed {} { return $breed } } ::dog % dog spot dalmatian -color spotted -akc 1 ::spot % spot breed dalmatian }] [para] The drawback is that this syntax is non-standard, and may limit the compatibility of your new type with other people's code. For example, Snit assumes that it can create [sectref COMPONENTS] using the standard creation syntax. [subsection {Are there any limitations on constructor arguments?}] Constructor argument lists are subject to the same limitations as those on instance method argument lists. It has the same implicit arguments, and can contain default values and the [var args] argument. [subsection "Is there anything special about writing the constructor?"] Yes. Writing the constructor can be tricky if you're delegating options to components, and there are specific issues relating to [cmd snit::widget]s and [cmd snit::widgetadaptor]s. See [sectref {DELEGATION}], [sectref {WIDGETS}], [sectref {WIDGET ADAPTORS}], and [sectref {THE TK OPTION DATABASE}]. [section DESTRUCTORS] [subsection {What is a destructor?}] A destructor is a special kind of method that's called when an object is destroyed. It's responsible for doing any necessary clean-up when the object goes away: destroying [sectref COMPONENTS], closing files, and so forth. [subsection {How do I define a destructor?}] Destructors are defined by using the [cmd destructor] statement in the type definition. [para] Suppose we're maintaining a list of pedigreed dogs; then we'll want to remove dogs from it when they are destroyed. [para] [example {snit::type dog { option -akc 0 typevariable akcList {} constructor {args} { $self configurelist $args if {$options(-akc)} { lappend akcList $self } } destructor { set ndx [lsearch $akcList $self] if {$ndx != -1} { set akcList [lreplace $akcList $ndx $ndx] } } typemethod akclist {} { return $akcList } } }] [para] [subsection {Are there any limitations on destructor arguments?}] Yes; a destructor has no explicit arguments. [subsection {What implicit arguments are passed to the destructor?}] The destructor gets the same implicit arguments that are passed to [sectref {INSTANCE METHODS}]: [var type], [var selfns], [var win], and [var self]. [subsection {Must components be destroyed explicitly?}] Yes and no. [para] Any Tk widgets created by a [cmd snit::widget] or [cmd snit::widgetadaptor] will be destroyed automatically by Tk when the megawidget is destroyed, in keeping with normal Tk behavior (destroying a parent widget destroys the whole tree). [para] Components of normal [cmd snit::types], on the other hand, are never destroyed automatically, nor are non-widget components of Snit megawidgets. If your object creates them in its constructor, then it should generally destroy them in its destructor. [subsection {Is there any special about writing a destructor?}] Yes. If an object's constructor throws an error, the object's destructor will be called to clean up; this means that the object might not be completely constructed when the destructor is called. This can cause the destructor to throw its own error; the result is usually misleading, confusing, and unhelpful. Consequently, it's important to write your destructor so that it's fail-safe. [para] For example, a [cmd dog] might create a [cmd tail] component; the component will need to be destroyed. But suppose there's an error while processing the creation options--the destructor will be called, and there will be no [cmd tail] to destroy. The simplest solution is generally to catch and ignore any errors while destroying components. [example {snit::type dog { component tail constructor {args} { $self configurelist $args set tail [tail %AUTO%] } destructor { catch {$tail destroy} } } }] [section COMPONENTS] [subsection {What is a component?}] Often an object will create and manage a number of other objects. A Snit megawidget, for example, will often create a number of Tk widgets. These objects are part of the main object; it is composed of them, so they are called components of the object. [para] But Snit also has a more precise meaning for [sectref COMPONENTS COMPONENT]. The components of a Snit object are those objects to which methods or options can be delegated. (See [sectref DELEGATION] for more information about delegation.) [subsection {How do I declare a component?}] First, you must decide what role a component plays within your object, and give the role a name. Then, you declare the component using its role name and the [cmd component] statement. The [cmd component] statement declares an [term {instance variable}] which is used to store the component's command name when the component is created. [para] For example, suppose your [cmd dog] object creates a [cmd tail] object (the better to wag with, no doubt): [para] [example {snit::type dog { component mytail constructor {args} { # Create and save the component's command set mytail [tail %AUTO% -partof $self] $self configurelist $args } method wag {} { $mytail wag } } }] [para] As shown here, it doesn't matter what the [cmd tail] object's real name is; the [cmd dog] object refers to it by its component name. [para] The above example shows one way to delegate the [method wag] method to the [var mytail] component; see [sectref DELEGATION] for an easier way. [subsection {How is a component named?}] A component has two names. The first name is that of the component variable; this represents the role the component object plays within the Snit object. This is the component name proper, and is the name used to refer to the component within Snit code. The second name is the name of the actual component object created by the Snit object's constructor. This second name is always a Tcl command name, and is referred to as the component's object name. [para] In the example in the previous question, the component name is [const mytail]; the [const mytail] component's object name is chosen automatically by Snit since [const %AUTO%] was used when the component object was created. [subsection {Are there any limitations on component names?}] Yes. [cmd snit::widget] and [cmd snit::widgetadaptor] objects have a special component called the [var hull] component; thus, the name [var hull] should be used for no other purpose. [para] Otherwise, since component names are in fact instance variable names they must follow the rules for [sectref {INSTANCE VARIABLES}]. [subsection {What is an owned component?}] An [term owned] component is a component whose object command's lifetime is controlled by the [cmd snit::type] or [cmd snit::widget]. [para] As stated above, a component is an object to which our object can delegate methods or options. Under this definition, our object will usually create its component objects, but not necessarily. Consider the following: a dog object has a tail component; but tail knows that it's part of the dog: [example {snit::type dog { component mytail constructor {args} { set mytail [tail %AUTO% -partof $self] $self configurelist $args } destructor { catch {$mytail destroy} } delegate method wagtail to mytail as wag method bark {} { return "$self barked." } } snit::type tail { component mydog option -partof -readonly yes constructor {args} { $self configurelist $args set mydog $options(-partof) } method wag {} { return "Wag, wag." } method pull {} { $mydog bark } } }] Thus, if you ask a dog to wag its tail, it tells its tail to wag; and if you pull the dog's tail, the tail tells the dog to bark. In this scenario, the tail is a component of the dog, and the dog is a component of the tail, but the dog owns the tail and not the other way around. [subsection {What does the install command do?}] The [cmd install] command creates an owned component using a specified command, and assigns the result to the component's instance variable. For example: [example {snit::type dog { component mytail constructor {args} { # set mytail [tail %AUTO% -partof $self] install mytail using tail %AUTO% -partof $self $self configurelist $args } } }] In a [cmd snit::type]'s code, the [cmd install] command shown above is equivalent to the [const {set mytail}] command that's commented out. In a [cmd snit::widget]'s or [cmd snit::widgetadaptor]'s, code, however, the [cmd install] command also queries [sectref {THE TK OPTION DATABASE}] and initializes the new component's options accordingly. For consistency, it's a good idea to get in the habit of using [cmd install] for all owned components. [subsection {Must owned components be created in the constructor?}] No, not necessarily. In fact, there's no reason why an object can't destroy and recreate a component multiple times over its own lifetime. [subsection {Are there any limitations on component object names?}] Yes. [para] Component objects which are Tk widgets or megawidgets must have valid Tk window names. [para] Component objects which are not widgets or megawidgets must have fully-qualified command names, i.e., names which include the full namespace of the command. Note that Snit always creates objects with fully qualified names. [para] Next, the object names of components and owned by your object must be unique. This is no problem for widget components, since widget names are always unique; but consider the following code: [para] [example {snit::type tail { ... } snit::type dog { delegate method wag to mytail constructor {} { install mytail using tail mytail } } }] [para] This code uses the component name, [const "mytail"], as the component object name. This is not good, and here's why: Snit instance code executes in the Snit type's namespace. In this case, the [const mytail] component is created in the [const ::dog::] namespace, and will thus have the name [cmd ::dog::mytail]. [para] Now, suppose you create two dogs. Both dogs will attempt to create a tail called [cmd ::dog::mytail]. The first will succeed, and the second will fail, since Snit won't let you create an object if its name is already a command. Here are two ways to avoid this situation: [para] First, if the component type is a [cmd snit::type] you can specify [const %AUTO%] as its name, and be guaranteed to get a unique name. This is the safest thing to do: [para] [example { install mytail using tail %AUTO% }] [para] If the component type isn't a [cmd snit::type] you can create the component in the object's instance namespace: [para] [example { install mytail using tail ${selfns}::mytail }] [para] Make sure you pick a unique name within the instance namespace. [subsection {Must I destroy the components I own?}] That depends. When a parent widget is destroyed, all child widgets are destroyed automatically. Thus, if your object is a [cmd snit::widget] or [cmd snit::widgetadaptor] you don't need to destroy any components that are widgets, because they will generally be children or descendants of your megawidget. [para] If your object is an instance of [cmd snit::type], though, none of its owned components will be destroyed automatically, nor will be non-widget components of a [cmd snit::widget] be destroyed automatically. All such owned components must be destroyed explicitly, or they won't be destroyed at all. [subsection {Can I expose a component's object command as part of my interface?}] Yes, and there are two ways to do it. The most appropriate way is usually to use [sectref DELEGATION]. Delegation allows you to pass the options and methods you specify along to particular components. This effectively hides the components from the users of your type, and ensures good encapsulation. [para] However, there are times when it's appropriate, not to mention simpler, just to make the entire component part of your type's public interface. [subsection {How do I expose a component's object command?}] When you declare the component, specify the [cmd component] statement's [const -public] option. The value of this option is the name of a method which will be delegated to your component's object command. [para] For example, supposed you've written a combobox megawidget which owns a listbox widget, and you want to make the listbox's entire interface public. You can do it like this: [para] [example {snit::widget combobox { component listbox -public listbox constructor {args} { install listbox using listbox $win.listbox .... } } combobox .mycombo .mycombo listbox configure -width 30 }] [para] Your comobox widget, [cmd .mycombo], now has a [method listbox] method which has all of the same subcommands as the listbox widget itself. Thus, the above code sets the listbox component's width to 30. [para] Usually you'll let the method name be the same as the component name; however, you can name it anything you like. [section {TYPE COMPONENTS}] [subsection {What is a type component?}] A type component is a component that belongs to the type itself instead of to a particular instance of the type. The relationship between components and type components is the same as the relationship between [sectref {INSTANCE VARIABLES}] and [sectref {TYPE VARIABLES}]. Both [sectref {INSTANCE METHODS}] and [sectref {TYPE METHODS}] can be delegated to type components. [para] Once you understand [sectref COMPONENTS] and [sectref {DELEGATION}], type components are just more of the same. [subsection {How do I declare a type component?}] Declare a type component using the [cmd typecomponent] statement. It takes the same options ([const -inherit] and [const -public]) as the [cmd component] statement does, and defines a type variable to hold the type component's object command. [para] Suppose in your model you've got many dogs, but only one veterinarian. You might make the veterinarian a type component. [example {snit::type veterinarian { ... } snit::type dog { typecomponent vet # ... } }] [subsection {How do I install a type component?}] Just use the [cmd set] command to assign the component's object command to the type component. Because types (even [cmd snit::widget] types) are not widgets, and do not have options anyway, the extra features of the [cmd install] command are not needed. [para] You'll usually install type components in the type constructor, as shown here: [example {snit::type veterinarian { ... } snit::type dog { typecomponent vet typeconstructor { set vet [veterinarian %AUTO%] } } }] [subsection {Are there any limitations on type component names?}] Yes, the same as on [sectref {INSTANCE VARIABLES}], [sectref {TYPE VARIABLES}], and normal [sectref COMPONENTS]. [section DELEGATION] [subsection {What is delegation?}] Delegation, simply put, is when you pass a task you've been given to one of your assistants. (You do have assistants, don't you?) Snit objects can do the same thing. The following example shows one way in which the [cmd dog] object can delegate its [cmd wag] method and its [option -taillength] option to its [cmd tail] component. [para] [example {snit::type dog { variable mytail option -taillength -configuremethod SetTailOption -cgetmethod GetTailOption method SetTailOption {option value} { $mytail configure $option $value } method GetTailOption {option} { $mytail cget $option } method wag {} { $mytail wag } constructor {args} { install mytail using tail %AUTO% -partof $self $self configurelist $args } } }] [para] This is the hard way to do it, by it demonstrates what delegation is all about. See the following answers for the easy way to do it. [para] Note that the constructor calls the [method configurelist] method [cmd after] it creates its [cmd tail]; otherwise, if [option -taillength] appeared in the list of [var args] we'd get an error. [subsection {How can I delegate a method to a component object?}] Delegation occurs frequently enough that Snit makes it easy. Any method can be delegated to any component or type component by placing a single [cmd delegate] statement in the type definition. (See [sectref COMPONENTS] and [sectref {TYPE COMPONENTS}] for more information about component names.) [para] For example, here's a much better way to delegate the [cmd dog] object's [cmd wag] method: [para] [example {% snit::type dog { delegate method wag to mytail constructor {} { install mytail using tail %AUTO% } } ::dog % snit::type tail { method wag {} { return "Wag, wag, wag."} } ::tail % dog spot ::spot % spot wag Wag, wag, wag. }] [para] This code has the same effect as the code shown under the previous question: when a [cmd dog]'s [cmd wag] method is called, the call and its arguments are passed along automatically to the [cmd tail] object. [para] Note that when a component is mentioned in a [cmd delegate] statement, the component's instance variable is defined implicitly. However, it's still good practice to declare it explicitly using the [cmd component] statement. [para] Note also that you can define a method name using the [cmd method] statement, or you can define it using [cmd delegate]; you can't do both. [subsection {Can I delegate to a method with a different name?}] Suppose you wanted to delegate the [cmd dog]'s [method wagtail] method to the [cmd tail]'s [method wag] method. After all you wag the tail, not the dog. It's easily done: [para] [example {snit::type dog { delegate method wagtail to mytail as wag constructor {args} { install mytail using tail %AUTO% -partof $self $self configurelist $args } } }] [para] [subsection {Can I delegate to a method with additional arguments?}] Suppose the [cmd tail]'s [method wag] method takes as an argument the number of times the tail should be wagged. You want to delegate the [cmd dog]'s [method wagtail] method to the [cmd tail]'s [method wag] method, specifying that the tail should be wagged exactly three times. This is easily done, too: [para] [example {snit::type dog { delegate method wagtail to mytail as {wag 3} # ... } snit::type tail { method wag {count} { return [string repeat "Wag " $count] } # ... } }] [para] [subsection {Can I delegate a method to something other than an object?}] Normal method delegation assumes that you're delegating a method (a subcommand of an object command) to a method of another object (a subcommand of a different object command). But not all Tcl objects follow Tk conventions, and not everything you'd to which you'd like to delegate a method is necessary an object. Consequently, Snit makes it easy to delegate a method to pretty much anything you like using the [cmd delegate] statement's [const using] clause. [para] Suppose your dog simulation stores dogs in a database, each dog as a single record. The database API you're using provides a number of commands to manage records; each takes the record ID (a string you choose) as its first argument. For example, [cmd saverec] saves a record. If you let the record ID be the name of the dog object, you can delegate the dog's [method save] method to the [cmd saverec] command as follows: [example {snit::type dog { delegate method save using {saverec %s} } }] The [const %s] is replaced with the instance name when the [method save] method is called; any additional arguments are the appended to the resulting command. [para] The [const using] clause understands a number of other %-conversions; in addition to the instance name, you can substitute in the method name ([const %m]), the type name ([const %t]), the instance namespace ([const %n]), the Tk window name ([const %w]), and, if a component or typecomponent name was given in the [cmd delegate] statement, the component's object command ([const %c]). [subsection {How can I delegate a method to a type component object?}] Just exactly as you would to a component object. The [cmd {delegate method}] statement accepts both component and type component names in its [const to] clause. [subsection {How can I delegate a type method to a type component object?}] Use the [cmd {delegate typemethod}] statement. It works like [cmd {delegate method}], with these differences: first, it defines a type method instead of an instance method; second, the [const using] clause ignores the [const {%s}], [const {%n}], and [const {%w}] %-conversions. [para] Naturally, you can't delegate a type method to an instance component...Snit wouldn't know which instance should receive it. [subsection {How can I delegate an option to a component object?}] The first question in this section (see [sectref DELEGATION]) shows one way to delegate an option to a component; but this pattern occurs often enough that Snit makes it easy. For example, every [cmd tail] object has a [option -length] option; we want to allow the creator of a [cmd dog] object to set the tail's length. We can do this: [para] [example {% snit::type dog { delegate option -length to mytail constructor {args} { install mytail using tail %AUTO% -partof $self $self configurelist $args } } ::dog % snit::type tail { option -partof option -length 5 } ::tail % dog spot -length 7 ::spot % spot cget -length 7 }] [para] This produces nearly the same result as the [const -configuremethod] and [const -cgetmethod] shown under the first question in this section: whenever a [cmd dog] object's [option -length] option is set or retrieved, the underlying [cmd tail] object's option is set or retrieved in turn. [para] Note that you can define an option name using the [cmd option] statement, or you can define it using [cmd delegate]; you can't do both. [subsection {Can I delegate to an option with a different name?}] In the previous answer we delegated the [cmd dog]'s [option -length] option down to its [cmd tail]. This is, of course, wrong. The dog has a length, and the tail has a length, and they are different. What we'd really like to do is give the [cmd dog] a [option -taillength] option, but delegate it to the [cmd tail]'s [option -length] option: [para] [example {snit::type dog { delegate option -taillength to mytail as -length constructor {args} { set mytail [tail %AUTO% -partof $self] $self configurelist $args } } }] [para] [subsection {How can I delegate any unrecognized method or option to a component object?}] It may happen that a Snit object gets most of its behavior from one of its components. This often happens with [cmd snit::widgetadaptors], for example, where we wish to slightly the modify the behavior of an existing widget. To carry on with our [cmd dog] example, however, suppose that we have a [cmd snit::type] called [cmd animal] that implements a variety of animal behaviors--moving, eating, sleeping, and so forth. We want our [cmd dog] objects to inherit these same behaviors, while adding dog-like behaviors of its own. Here's how we can give a [cmd dog] methods and options of its own while delegating all other methods and options to its [cmd animal] component: [para] [example {snit::type dog { delegate option * to animal delegate method * to animal option -akc 0 constructor {args} { install animal using animal %AUTO% -name $self $self configurelist $args } method wag {} { return "$self wags its tail" } } }] [para] That's it. A [cmd dog] is now an [cmd animal] that has a [option -akc] option and can [cmd wag] its tail. [para] Note that we don't need to specify the full list of method names or option names that [cmd animal] will receive. It gets anything [cmd dog] doesn't recognize--and if it doesn't recognize it either, it will simply throw an error, just as it should. [para] You can also delegate all unknown type methods to a type component using [cmd {delegate typemethod *}]. [subsection {How can I delegate all but certain methods or options to a component?}] In the previous answer, we said that every [cmd dog] is an [cmd animal] by delegating all unknown methods and options to the [var animal] component. But what if the [cmd animal] type has some methods or options that we'd like to suppress? [para] One solution is to explicitly delegate all the options and methods, and forgo the convenience of [cmd {delegate method *}] and [cmd {delegate option *}]. But if we wish to suppress only a few options or methods, there's an easier way: [para] [example {snit::type dog { delegate option * to animal except -numlegs delegate method * to animal except {fly climb} # ... constructor {args} { install animal using animal %AUTO% -name $self -numlegs 4 $self configurelist $args } # ... } }] [para] Dogs have four legs, so we specify that explicitly when we create the [var animal] component, and explicitly exclude [option -numlegs] from the set of delegated options. Similarly, dogs can neither [method fly] nor [method climb], so we exclude those [cmd animal] methods as shown. [subsection {Can a hierarchical method be delegated?}] Yes; just specify multiple words in the delegated method's name: [para] [example {snit::type tail { method wag {} {return "Wag, wag"} method droop {} {return "Droop, droop"} } snit::type dog { delegate method {tail wag} to mytail delegate method {tail droop} to mytail # ... constructor {args} { install mytail using tail %AUTO% $self configurelist $args } # ... } }] [para] Unrecognized hierarchical methods can also be delegated; the following code delegates all subcommands of the "tail" method to the "mytail" component: [para] [example {snit::type dog { delegate method {tail *} to mytail # ... } }] [para] [section WIDGETS] [subsection {What is a snit::widget?}] A [cmd snit::widget] is the Snit version of what Tcl programmers usually call a [term megawidget]: a widget-like object usually consisting of one or more Tk widgets all contained within a Tk frame. [para] A [cmd snit::widget] is also a special kind of [cmd snit::type]. Just about everything in this FAQ list that relates to [cmd snit::types] also applies to [cmd snit::widgets]. [subsection {How do I define a snit::widget?}] [cmd snit::widgets] are defined using the [cmd snit::widget] command, just as [cmd snit::types] are defined by the [cmd snit::type] command. [para] The body of the definition can contain all of the same kinds of statements, plus a couple of others which will be mentioned below. [subsection {How do snit::widgets differ from snit::types?}] [list_begin itemized] [item] The name of an instance of a [cmd snit::type] can be any valid Tcl command name, in any namespace. The name of an instance of a [cmd snit::widget] must be a valid Tk widget name, and its parent widget must already exist. [item] An instance of a [cmd snit::type] can be destroyed by calling its [cmd destroy] method. Instances of a [cmd snit::widget] have no destroy method; use the Tk [cmd destroy] command instead. [item] Every instance of a [cmd snit::widget] has one predefined component called its [var hull] component. The hull is usually a Tk [cmd frame] or [cmd toplevel] widget; any other widgets created as part of the [cmd snit::widget] will usually be contained within the hull. [item] [cmd snit::widget]s can have their options receive default values from [sectref {THE TK OPTION DATABASE}]. [list_end] [subsection {What is a hull component?}] Snit can't create a Tk widget object; only Tk can do that. Thus, every instance of a [cmd snit::widget] must be wrapped around a genuine Tk widget; this Tk widget is called the [term {hull component}]. Snit effectively piggybacks the behavior you define (methods, options, and so forth) on top of the hull component so that the whole thing behaves like a standard Tk widget. [para] For [cmd snit::widget]s the hull component must be a Tk widget that defines the [const -class] option. [para] [cmd snit::widgetadaptor]s differ from [cmd snit::widget]s chiefly in that any kind of widget can be used as the hull component; see [sectref {WIDGET ADAPTORS}]. [subsection {How can I set the hull type for a snit::widget?}] A [cmd snit::widget]'s hull component will usually be a Tk [cmd frame] widget; however, it may be any Tk widget that defines the [const -class] option. You can explicitly choose the hull type you prefer by including the [cmd hulltype] command in the widget definition: [para] [example {snit::widget mytoplevel { hulltype toplevel # ... } }] [para] If no [cmd hulltype] command appears, the hull will be a [cmd frame]. [para] By default, Snit recognizes the following hull types: the Tk widgets [cmd frame], [cmd labelframe], [cmd toplevel], and the Tile widgets [cmd ttk::frame], [cmd ttk::labelframe], and [cmd ttk::toplevel]. To enable the use of some other kind of widget as the hull type, you can [cmd lappend] the widget command to the variable [var snit::hulltypes] (always provided the widget defines the [const -class] option. For example, suppose Tk gets a new widget type called a [cmd prettyframe]: [para] [example {lappend snit::hulltypes prettyframe snit::widget mywidget { hulltype prettyframe # ... } }] [para] [subsection {How should I name widgets which are components of a snit::widget?}] Every widget, whether a genuine Tk widget or a Snit megawidget, has to have a valid Tk window name. When a [cmd snit::widget] is first created, its instance name, [var self], is a Tk window name; however, if the [cmd snit::widget] is used as the hull component by a [cmd snit::widgetadaptor] its instance name will be changed to something else. For this reason, every [cmd snit::widget] method, constructor, destructor, and so forth is passed another implicit argument, [var win], which is the window name of the megawidget. Any children should be named using [var win] as the root. [para] Thus, suppose you're writing a toolbar widget, a frame consisting of a number of buttons placed side-by-side. It might look something like this: [para] [example {snit::widget toolbar { delegate option * to hull constructor {args} { button $win.open -text Open -command [mymethod open] button $win.save -text Save -command [mymethod save] # .... $self configurelist $args } } }] [para] See also the question on renaming objects, toward the top of this file. [section {WIDGET ADAPTORS}] [subsection {What is a snit::widgetadaptor?}] A [cmd snit::widgetadaptor] is a kind of [cmd snit::widget]. Whereas a [cmd snit::widget]'s hull is automatically created and is always a Tk frame, a [cmd snit::widgetadaptor] can be based on any Tk widget--or on any Snit megawidget, or even (with luck) on megawidgets defined using some other package. [para] It's called a [term {widget adaptor}] because it allows you to take an existing widget and customize its behavior. [subsection {How do I define a snit::widgetadaptor?}] Use the [cmd snit::widgetadaptor] command. The definition for a [cmd snit::widgetadaptor] looks just like that for a [cmd snit::type] or [cmd snit::widget], except that the constructor must create and install the hull component. [para] For example, the following code creates a read-only text widget by the simple device of turning its [method insert] and [method delete] methods into no-ops. Then, we define new methods, [method ins] and [method del], which get delegated to the hull component as [method insert] and [method delete]. Thus, we've adapted the text widget and given it new behavior while still leaving it fundamentally a text widget. [para] [example {::snit::widgetadaptor rotext { constructor {args} { # Create the text widget; turn off its insert cursor installhull using text -insertwidth 0 # Apply any options passed at creation time. $self configurelist $args } # Disable the text widget's insert and delete methods, to # make this readonly. method insert {args} {} method delete {args} {} # Enable ins and del as synonyms, so the program can insert and # delete. delegate method ins to hull as insert delegate method del to hull as delete # Pass all other methods and options to the real text widget, so # that the remaining behavior is as expected. delegate method * to hull delegate option * to hull } }] [para] The most important part is in the constructor. Whereas [cmd snit::widget] creates the hull for you, [cmd snit::widgetadaptor] cannot -- it doesn't know what kind of widget you want. So the first thing the constructor does is create the hull component (a Tk text widget in this case), and then installs it using the [cmd installhull] command. [para] [emph Note:] There is no instance command until you create one by installing a hull component. Any attempt to pass methods to [var \$self] prior to calling [cmd installhull] will fail. [subsection {Can I adapt a widget created elsewhere in the program?}] Yes. [para] At times, it can be convenient to adapt a pre-existing widget instead of creating your own. For example, the Bwidget [cmd PagesManager] widget manages a set of [cmd frame] widgets, only one of which is visible at a time. The application chooses which [cmd frame] is visible. All of the These [cmd frame]s are created by the [cmd PagesManager] itself, using its [method add] method. It's convenient to adapt these frames to do what we'd like them to do. [para] In a case like this, the Tk widget will already exist when the [cmd snit::widgetadaptor] is created. Snit provides an alternate form of the [cmd installhull] command for this purpose: [para] [example {snit::widgetadaptor pageadaptor { constructor {args} { # The widget already exists; just install it. installhull $win # ... } } }] [subsection {Can I adapt another megawidget?}] Maybe. If the other megawidget is a [cmd snit::widget] or [cmd snit::widgetadaptor], then yes. If it isn't then, again, maybe. You'll have to try it and see. You're most likely to have trouble with widget destruction--you have to make sure that your megawidget code receives the [const ] event before the megawidget you're adapting does. [section {THE TK OPTION DATABASE}] [subsection {What is the Tk option database?}] The Tk option database is a database of default option values maintained by Tk itself; every Tk application has one. The concept of the option database derives from something called the X Windows resource database; however, the option database is available in every Tk implementation, including those which do not use the X Windows system (e.g., Microsoft Windows). [para] Full details about the Tk option database are beyond the scope of this document; both [emph {Practical Programming in Tcl and Tk}] by Welch, Jones, and Hobbs, and [emph {Effective Tcl/Tk Programming}] by Harrison and McClennan., have good introductions to it. [para] Snit is implemented so that most of the time it will simply do the right thing with respect to the option database, provided that the widget developer does the right thing by Snit. The body of this section goes into great deal about what Snit requires. The following is a brief statement of the requirements, for reference. [para] [list_begin itemized] [item] If the widget's default widget class is not what is desired, set it explicitly using the [cmd widgetclass] statement in the widget definition. [item] When defining or delegating options, specify the resource and class names explicitly when necessary. [item] Use the [cmd {installhull using}] command to create and install the hull for [cmd snit::widgetadaptor]s. [item] Use the [cmd install] command to create and install all components which are widgets. [item] Use the [cmd install] command to create and install components which aren't widgets if you'd like them to receive option values from the option database. [list_end] [para] The interaction of Tk widgets with the option database is a complex thing; the interaction of Snit with the option database is even more so, and repays attention to detail. [subsection {Do snit::types use the Tk option database?}] No, they don't; querying the option database requires a Tk window name, and [cmd snit::type]s don't have one. [para] If you create an instance of a [cmd snit::type] as a component of a [cmd snit::widget] or [cmd snit::widgetadaptor], on the other hand, and if any options are delegated to the component, and if you use [cmd install] to create and install it, then the megawidget will query the option database on the [cmd snit::type]'s behalf. This might or might not be what you want, so take care. [subsection {What is my snit::widget's widget class?}] Every Tk widget has a "widget class": a name that is used when adding option settings to the database. For Tk widgets, the widget class is the same as the widget command name with an initial capital. For example, the widget class of the Tk [cmd button] widget is [const Button]. [para] Similarly, the widget class of a [cmd snit::widget] defaults to the unqualified type name with the first letter capitalized. For example, the widget class of [para] [example {snit::widget ::mylibrary::scrolledText { ... } }] [para] is [const ScrolledText]. [para] The widget class can also be set explicitly using the [cmd widgetclass] statement within the [cmd snit::widget] definition: [para] [example {snit::widget ::mylibrary::scrolledText { widgetclass Text # ... } }] [para] The above definition says that a [cmd scrolledText] megawidget has the same widget class as an ordinary [cmd text] widget. This might or might not be a good idea, depending on how the rest of the megawidget is defined, and how its options are delegated. [subsection {What is my snit::widgetadaptor's widget class?}] The widget class of a [cmd snit::widgetadaptor] is just the widget class of its hull widget; Snit has no control over this. [para] Note that the widget class can be changed only for [cmd frame] and [cmd toplevel] widgets, which is why these are the valid hull types for [cmd snit::widget]s. [para] Try to use [cmd snit::widgetadaptor]s only to make small modifications to another widget's behavior. Then, it will usually not make sense to change the widget's widget class anyway. [subsection {What are option resource and class names?}] Every Tk widget option has three names: the option name, the resource name, and the class name. The option name begins with a hyphen and is all lowercase; it's used when creating widgets, and with the [cmd configure] and [cmd cget] commands. [para] The resource and class names are used to initialize option default values by querying the option database. The resource name is usually just the option name minus the hyphen, but may contain uppercase letters at word boundaries; the class name is usually just the resource name with an initial capital, but not always. For example, here are the option, resource, and class names for several Tk [cmd text] widget options: [para] [example { -background background Background -borderwidth borderWidth BorderWidth -insertborderwidth insertBorderWidth BorderWidth -padx padX Pad }] [para] As is easily seen, sometimes the resource and class names can be inferred from the option name, but not always. [subsection {What are the resource and class names for my megawidget's options?}] For options implicitly delegated to a component using [cmd {delegate option *}], the resource and class names will be exactly those defined by the component. The [cmd configure] method returns these names, along with the option's default and current values: [para] [example {% snit::widget mytext { delegate option * to text constructor {args} { install text using text .text # ... } # ... } ::mytext % mytext .text .text % .text configure -padx -padx padX Pad 1 1 % }] [para] For all other options (whether locally defined or explicitly delegated), the resource and class names can be defined explicitly, or they can be allowed to have default values. [para] By default, the resource name is just the option name minus the hyphen; the the class name is just the option name with an initial capital letter. For example, suppose we explicitly delegate "-padx": [para] [example {% snit::widget mytext { option -myvalue 5 delegate option -padx to text delegate option * to text constructor {args} { install text using text .text # ... } # ... } ::mytext % mytext .text .text % .text configure -myvalue -myvalue myvalue Myvalue 5 5 % .text configure -padx -padx padx Padx 1 1 % }] [para] Here the resource and class names are chosen using the default rules. Often these rules are sufficient, but in the case of "-padx" we'd most likely prefer that the option's resource and class names are the same as for the built-in Tk widgets. This is easily done: [para] [example {% snit::widget mytext { delegate option {-padx padX Pad} to text # ... } ::mytext % mytext .text .text % .text configure -padx -padx padX Pad 1 1 % }] [subsection {How does Snit initialize my megawidget's locally-defined options?}] The option database is queried for each of the megawidget's locally-defined options, using the option's resource and class name. If the result isn't "", then it replaces the default value given in widget definition. In either case, the default can be overridden by the caller. For example, [para] [example {option add *Mywidget.texture pebbled snit::widget mywidget { option -texture smooth # ... } mywidget .mywidget -texture greasy }] [para] Here, [const -texture] would normally default to "smooth", but because of the entry added to the option database it defaults to "pebbled". However, the caller has explicitly overridden the default, and so the new widget will be "greasy". [subsection {How does Snit initialize delegated options?}] That depends on whether the options are delegated to the hull, or to some other component. [subsection {How does Snit initialize options delegated to the hull?}] A [cmd snit::widget]'s hull is a widget, and given that its class has been set it is expected to query the option database for itself. The only exception concerns options that are delegated to it with a different name. Consider the following code: [para] [example {option add *Mywidget.borderWidth 5 option add *Mywidget.relief sunken option add *Mywidget.hullbackground red option add *Mywidget.background green snit::widget mywidget { delegate option -borderwidth to hull delegate option -hullbackground to hull as -background delegate option * to hull # ... } mywidget .mywidget set A [.mywidget cget -relief] set B [.mywidget cget -hullbackground] set C [.mywidget cget -background] set D [.mywidget cget -borderwidth] }] [para] The question is, what are the values of variables A, B, C and D? [para] The value of A is "sunken". The hull is a Tk frame which has been given the widget class [const Mywidget]; it will automatically query the option database and pick up this value. Since the [const -relief] option is implicitly delegated to the hull, Snit takes no action. [para] The value of B is "red". The hull will automatically pick up the value "green" for its [const -background] option, just as it picked up the [const -relief] value. However, Snit knows that [const -hullbackground] is mapped to the hull's [const -background] option; hence, it queries the option database for [const -hullbackground] and gets "red" and updates the hull accordingly. [para] The value of C is also "red", because [const -background] is implicitly delegated to the hull; thus, retrieving it is the same as retrieving [const -hullbackground]. Note that this case is unusual; the [const -background] option should probably have been excluded using the delegate statement's [const except] clause, or (more likely) delegated to some other component. [para] The value of D is "5", but not for the reason you think. Note that as it is defined above, the resource name for [const -borderwidth] defaults to [const borderwidth], whereas the option database entry is [const borderWidth], in accordance with the standard Tk naming for this option. As with [const -relief], the hull picks up its own [const -borderwidth] option before Snit does anything. Because the option is delegated under its own name, Snit assumes that the correct thing has happened, and doesn't worry about it any further. To avoid confusion, the [const -borderwidth] option should have been delegated like this: [para] [example { delegate option {-borderwidth borderWidth BorderWidth} to hull }] [para] For [cmd snit::widgetadaptor]s, the case is somewhat altered. Widget adaptors retain the widget class of their hull, and the hull is not created automatically by Snit. Instead, the [cmd snit::widgetadaptor] must call [cmd installhull] in its constructor. The normal way to do this is as follows: [para] [example {snit::widgetadaptor mywidget { # ... constructor {args} { # ... installhull using text -foreground white # ... } # ... } }] [para] In this case, the [cmd installhull] command will create the hull using a command like this: [para] [example { set hull [text $win -foreground white] }] [para] The hull is a [cmd text] widget, so its widget class is [const Text]. Just as with [cmd snit::widget] hulls, Snit assumes that it will pick up all of its normal option values automatically, without help from Snit. Options delegated from a different name are initialized from the option database in the same way as described above. [para] In earlier versions of Snit, [cmd snit::widgetadaptor]s were expected to call [cmd installhull] like this: [para] [example { installhull [text $win -foreground white] }] [para] This form still works--but Snit will not query the option database as described above. [subsection {How does Snit initialize options delegated to other components?}] For hull components, Snit assumes that Tk will do most of the work automatically. Non-hull components are somewhat more complicated, because they are matched against the option database twice. [para] A component widget remains a widget still, and is therefore initialized from the option database in the usual way. A [cmd text] widget remains a [cmd text] widget whether it is a component of a megawidget or not, and will be created as such. [para] But then, the option database is queried for all options delegated to the component, and the component is initialized accordingly--provided that the [cmd install] command is used to create it. [para] Before option database support was added to Snit, the usual way to create a component was to simply create it in the constructor and assign its command name to the component variable: [para] [example {snit::widget mywidget { delegate option -background to myComp constructor {args} { set myComp [text $win.text -foreground black] } } }] [para] The drawback of this method is that Snit has no opportunity to initialize the component properly. Hence, the following approach is now used: [para] [example {snit::widget mywidget { delegate option -background to myComp constructor {args} { install myComp using text $win.text -foreground black } } }] [para] The [cmd install] command does the following: [para] [list_begin itemized] [item] Builds a list of the options explicitly included in the [cmd install] command--in this case, [const -foreground]. [item] Queries the option database for all options delegated explicitly to the named component. [item] Creates the component using the specified command, after inserting into it a list of options and values read from the option database. Thus, the explicitly included options (like [const -foreground]) will override anything read from the option database. [item] If the widget definition implicitly delegated options to the component using [cmd {delegate option *}], then Snit calls the newly created component's [cmd configure] method to receive a list of all of the component's options. From this Snit builds a list of options implicitly delegated to the component which were not explicitly included in the [cmd install] command. For all such options, Snit queries the option database and configures the component accordingly. [list_end] You don't really need to know all of this; just use [cmd install] to install your components, and Snit will try to do the right thing. [subsection {What happens if I install a non-widget as a component of widget?}] A [cmd snit::type] never queries the option database. However, a [cmd snit::widget] can have non-widget components. And if options are delegated to those components, and if the [cmd install] command is used to install those components, then they will be initialized from the option database just as widget components are. [para] However, when used within a megawidget, [cmd install] assumes that the created component uses a reasonably standard widget-like creation syntax. If it doesn't, don't use [cmd install]. [section {ENSEMBLE COMMANDS}] [subsection {What is an ensemble command?}] An ensemble command is a command with subcommands. Snit objects are all ensemble commands; however, the term more usually refers to commands like the standard Tcl commands [cmd string], [cmd file], and [cmd clock]. In a sense, these are singleton objects--there's only one instance of them. [subsection {How can I create an ensemble command using Snit?}] There are two ways--as a [cmd snit::type], or as an instance of a [cmd snit::type]. [subsection {How can I create an ensemble command using an instance of a snit::type?}] Define a type whose [sectref {INSTANCE METHODS}] are the subcommands of your ensemble command. Then, create an instance of the type with the desired name. [para] For example, the following code uses [sectref {DELEGATION}] to create a work-alike for the standard [cmd string] command: [example {snit::type ::mynamespace::mystringtype { delegate method * to stringhandler constructor {} { set stringhandler string } } ::mynamespace::mystringtype mystring }] We create the type in a namespace, so that the type command is hidden; then we create a single instance with the desired name-- [cmd mystring], in this case. [para] This method has two drawbacks. First, it leaves the type command floating about. More seriously, your shiny new ensemble command will have [method info] and [method destroy] subcommands that you probably have no use for. But read on. [subsection {How can I create an ensemble command using a snit::type?}] Define a type whose [sectref {TYPE METHODS}] are the subcommands of your ensemble command.[para] For example, the following code uses [sectref {DELEGATION}] to create a work-alike for the standard [cmd string] command: [example {snit::type mystring { delegate typemethod * to stringhandler typeconstructor { set stringhandler string } } }] Now the type command itself is your ensemble command. [para] This method has only one drawback, and though it's major, it's also surmountable. Your new ensemble command will have [method create], [method info] and [method destroy] subcommands you don't want. And worse yet, since the [method create] method can be implicit, users of your command will accidentally be creating instances of your [cmd mystring] type if they should mispell one of the subcommands. The command will succeed--the first time--but won't do what's wanted. This is very bad. [para] The work around is to set some [sectref {PRAGMAS}], as shown here: [example {snit::type mystring { pragma -hastypeinfo no pragma -hastypedestroy no pragma -hasinstances no delegate typemethod * to stringhandler typeconstructor { set stringhandler string } } }] Here we've used the [cmd pragma] statement to tell Snit that we don't want the [method info] typemethod or the [method destroy] typemethod, and that our type has no instances; this eliminates the [method create] typemethod and all related code. As a result, our ensemble command will be well-behaved, with no unexpected subcommands. [section {PRAGMAS}] [subsection {What is a pragma?}] A pragma is an option you can set in your type definitions that affects how the type is defined and how it works once it is defined. [subsection {How do I set a pragma?}] Use the [cmd pragma] statement. Each pragma is an option with a value; each time you use the [cmd pragma] statement you can set one or more of them. [subsection {How can I get rid of the "info" type method?}] Set the [const -hastypeinfo] pragma to [const no]: [example {snit::type dog { pragma -hastypeinfo no # ... } }] Snit will refrain from defining the [method info] type method. [subsection {How can I get rid of the "destroy" type method?}] Set the [const -hastypedestroy] pragma to [const no]: [example {snit::type dog { pragma -hastypedestroy no # ... } }] Snit will refrain from defining the [method destroy] type method. [subsection {How can I get rid of the "create" type method?}] Set the [const -hasinstances] pragma to [const no]: [example {snit::type dog { pragma -hasinstances no # ... } }] Snit will refrain from defining the [method create] type method; if you call the type command with an unknown method name, you'll get an error instead of a new instance of the type. [para] This is useful if you wish to use a [cmd snit::type] to define an ensemble command rather than a type with instances. [para] Pragmas [const -hastypemethods] and [const -hasinstances] cannot both be false (or there'd be nothing left). [subsection {How can I get rid of type methods altogether?}] Normal Tk widget type commands don't have subcommands; all they do is create widgets--in Snit terms, the type command calls the [method create] type method directly. To get the same behavior from Snit, set the [const -hastypemethods] pragma to [const no]: [example {snit::type dog { pragma -hastypemethods no #... } # Creates ::spot dog spot # Tries to create an instance called ::create dog create spot }] Pragmas [const -hastypemethods] and [const -hasinstances] cannot both be false (or there'd be nothing left). [subsection {Why can't I create an object that replaces an old object with the same name?}] Up until Snit 0.95, you could use any name for an instance of a [cmd snit::type], even if the name was already in use by some other object or command. You could do the following, for example: [example {snit::type dog { ... } dog proc }] You now have a new dog named "proc", which is probably not something that you really wanted to do. As a result, Snit now throws an error if your chosen instance name names an existing command. To restore the old behavior, set the [const -canreplace] pragma to [const yes]: [example {snit::type dog { pragma -canreplace yes # ... } }] [subsection {How can I make my simple type run faster?}] In Snit 1.x, you can set the [const -simpledispatch] pragma to [const yes]. [para] Snit 1.x method dispatch is both flexible and fast, but the flexibility comes with a price. If your type doesn't require the flexibility, the [const -simpledispatch] pragma allows you to substitute a simpler dispatch mechanism that runs quite a bit faster. The limitations are these: [list_begin itemized] [item] Methods cannot be delegated. [item] [cmd uplevel] and [cmd upvar] do not work as expected: the caller's scope is two levels up rather than one. [item] The option-handling methods ([cmd cget], [cmd configure], and [cmd configurelist]) are very slightly slower. [list_end] In Snit 2.2, the [const -simpledispatch] macro is obsolete, and ignored; all Snit 2.2 method dispatch is faster than Snit 1.x's [const -simpledispatch]. [section {MACROS}] [subsection {What is a macro?}] A Snit macro is nothing more than a Tcl proc that's defined in the Tcl interpreter used to compile Snit type definitions. [subsection {What are macros good for?}] You can use Snit macros to define new type definition syntax, and to support conditional compilation. [subsection {How do I do conditional compilation?}] Suppose you want your type to use a fast C extension if it's available; otherwise, you'll fallback to a slower Tcl implementation. You want to define one set of methods in the first case, and another set in the second case. But how can your type definition know whether the fast C extension is available or not? [para] It's easily done. Outside of any type definition, define a macro that returns 1 if the extension is available, and 0 otherwise: [example {if {$gotFastExtension} { snit::macro fastcode {} {return 1} } else { snit::macro fastcode {} {return 0} } }] Then, use your macro in your type definition: [example {snit::type dog { if {[fastcode]} { # Fast methods method bark {} {...} method wagtail {} {...} } else { # Slow methods method bark {} {...} method wagtail {} {...} } } }] [subsection {How do I define new type definition syntax?}] Use a macro. For example, your [cmd snit::widget]'s [const -background] option should be propagated to a number of component widgets. You could implement that like this: [example {snit::widget mywidget { option -background -default white -configuremethod PropagateBackground method PropagateBackground {option value} { $comp1 configure $option $value $comp2 configure $option $value $comp3 configure $option $value } } }] For one option, this is fine; if you've got a number of options, it becomes tedious and error prone. So package it as a macro: [example {snit::macro propagate {option "to" components} { option $option -configuremethod Propagate$option set body "\n" foreach comp $components { append body "\$$comp configure $option \$value\n" } method Propagate$option {option value} $body } }] Then you can use it like this: [example {snit::widget mywidget { option -background default -white option -foreground default -black propagate -background to {comp1 comp2 comp3} propagate -foreground to {comp1 comp2 comp3} } }] [subsection {Are there are restrictions on macro names?}] Yes, there are. You can't redefine any standard Tcl commands or Snit type definition statements. You can use any other command name, including the name of a previously defined macro. [para] If you're using Snit macros in your application, go ahead and name them in the global namespace, as shown above. But if you're using them to define types or widgets for use by others, you should define your macros in the same namespace as your types or widgets. That way, they won't conflict with other people's macros. [para] If my fancy [cmd snit::widget] is called [cmd ::mylib::mywidget], for example, then I should define my [cmd propagate] macro as [cmd ::mylib::propagate]: [example {snit::macro mylib::propagate {option "to" components} { ... } snit::widget ::mylib::mywidget { option -background default -white option -foreground default -black mylib::propagate -background to {comp1 comp2 comp3} mylib::propagate -foreground to {comp1 comp2 comp3} } }] [vset CATEGORY snit] [include ../common-text/feedback.inc] [manpage_end] tcltk2/inst/tklibs/snit2.3.4/pkgIndex.tcl0000644000176200001440000000032215017041713017535 0ustar liggesusersif {[package vsatisfies [package provide Tcl] 8.5 9]} { package ifneeded snit 2.3.4 \ [list source [file join $dir snit2.tcl]] } package ifneeded snit 1.4.3 [list source [file join $dir snit.tcl]] tcltk2/inst/tklibs/snit2.3.4/ChangeLog0000644000176200001440000012536715017041713017053 0ustar liggesusers2013-02-01 Andreas Kupries * * Released and tagged Tcllib 1.15 ======================== * 2011-12-13 Andreas Kupries * * Released and tagged Tcllib 1.14 ======================== * 2011-01-24 Andreas Kupries * * Released and tagged Tcllib 1.13 ======================== * 2010-06-07 Andreas Kupries * validate.tcl (snit::double, validate): Applied patch by Will * pkgIndex.tcl: fixing the error message for max-limited * snit.man: double types. Bumped versions to 2.3.2 and 1.4.2. * snit.tcl: Extended testsuite. * snit2.tcl: * snit.test: 2010-04-30 Andreas Kupries * snitfaq.man: Fixed typo in 'package require' commands, reported by sigzero@gmail.com. 2009-12-07 Andreas Kupries * * Released and tagged Tcllib 1.12 ======================== * 2009-11-16 Andreas Kupries * main2.tcl (::snit::RT.typemethod.destroy) (::snit::RT.typemethod.info.instances): * main1.tcl (::snit::RT.typemethod.info.instances) (::snit::RT.typemethod.destroy): [Bug 2898640]. Fixed handling of * snit.tcl: unrelated namespaces by restricting the set of * snit2.tcl: children to look at. Bumped versions of v1 and v2 to * pkgIndex.tcl: 1.4.1 and 2.3.1 respectively. * snit.man: 2009-11-02 Andreas Kupries * snit.tcl: Bumped versions of v1 and v2 to 1.4 and 2.3 * snit2.tcl: respectively, taking the backward compatible * snit.man: API changes to validation types into account. * pkgIndex.tcl: 2009-10-31 Will Duquette * validate.tcl: Updated all Snit validation types to return the * snit.tcl: validated value, and to throw -errorcode INVALID on error. * snit.man: Relevant changes. 2009-09-29 Andreas Kupries * snit.test: Updated to handle changes in command error messages done in Tcl 8.6+. 2009-09-28 Andreas Kupries * snit.man: Committed a long-standing fix to a bug in the * snit.tcl: last entry. Wrap the close commands into catch * snit2.tcl: to handle the possibility of the std channels * pkgIndex.tcl: not existing. Bumped versions to 1.3.4 and * main1_83.tcl 2.2.4. * main1.tcl: * main2.tcl: 2009-06-22 Andreas Kupries * main1.tcl: Fix handling of hierarchical typemethods for missing * main1_83.tcl: subcommands. If a toplevel hmethod is not found * main2.tcl: we can assume it to be an instance name and do an * pkgIndex.tcl: implicit 'create' of it. If the toplevel hmethod * snit.tcl: has already been accepted however a missing submethod * snit2.tcl: has to error out, an implicit create is not possible * snit.test: any longer. Extended the testsuite to cover this case. Bumped the package versions to 2.2.3, and 1.3.3. 2009-04-21 Andreas Kupries * main1.tcl (::snit::Comp.Init): Close unused standard channels * main1_83.tcl (::snit::Comp.Init): to prevent the internal compile * main2.tcl (::snit::Comp.Init): interp from blocking a close/open * snit.tcl: dance to replace them in the main interp. Bumped the * snit2.tcl: packages to versions 1.3.2 and 2.2.2 respectively. * pkgIndex.tcl: 2008-12-12 Andreas Kupries * * Released and tagged Tcllib 1.11.1 ======================== * 2008-10-16 Andreas Kupries * * Released and tagged Tcllib 1.11 ======================== * 2008-08-20 Will Duquette * snitfaq.man: Finished up [SF Tcllib Bug 1658089]. 2008-05-16 Andreas Kupries * snitfaq.man: Fixed the sectref argument order issues. 2008-05-15 Andreas Kupries * snitfaq.man: Updated to changes in doctools (sub)section reference handling. 2007-12-04 Andreas Kupries * snit.test: Updated some results to changes in the Tcl 8.5 head. This fixes [SF Tcllib Bug 1844106], reported by Larry Virden . Thanks. 2007-09-12 Andreas Kupries * * Released and tagged Tcllib 1.10 ======================== * 2007-08-20 Andreas Kupries * snit.test: Fixed bad indices in tests causing the generation of bogus expected error messages. 2007-07-03 Andreas Kupries * main1_83.tcl (::snit::Comp.statement.oncget): Fixed double * main1.tcl (::snit::Comp.statement.oncget): import of instance * main2.tcl (::snit::Comp.statement.oncget): and type variables. * snit.man: Bumped versions to 1.3.1 and 2.2.1 respectively. * pkgIndex.tcl: * snit.tcl: * snit2.tcl: 2007-07-02 Andreas Kupries * snit.test: Snit versions bumped to 1.3 and 2.2. Extended * snit.man: 'info' method and typemethod with sub-methods * snitfaq.man: 'args', 'body' and 'default' to query method * main1.tcl: arguments, argument defaults, and bodies. * main1_83.tcl: * main2.tcl: * pkgIndex.tcl: 2007-06-22 Andreas Kupries * snitfaq.man: Replaced deprecated {expand} with {*}. 2007-05-01 Andreas Kupries * main2.tcl: [Bug 1710640]. Replaced deprecated {expand} with {*}. * snit.test: Updated to changes in 8.5a6. 2007-03-21 Andreas Kupries * snit.man: Fixed all warnings due to use of now deprecated * snitfaq.man: commands. Added a section about how to give feedback. 2007-02-12 Andreas Kupries * snitfaq.man: Fixed typos, etc. reported in [Bug 1658089]. 2006-10-19 Jeff Hobbs * snit.man, main1.tcl, main1_83.tcl, main2.tcl: Allow -class to be passed to snit::widget. [Patch 1580120] * pkgIndex.tcl, snit.tcl, snit2.tcl: Bumped versions to 1.2.1 / 2.1.1. 2006-10-03 Andreas Kupries * * Released and tagged Tcllib 1.9 ======================== * 2006-09-20 Will Duquette * pkgIndex.tcl, snit2.tcl, snit.man, snitfaq.man, README.txt: Bumped the version number from 2.0 to 2.1, per Andreas' request. Also, added details about the implications of 2.1's use of [namespace path] to README.txt and the Snit FAQ. 2006-09-16 Andreas Kupries * snit_tcl83_utils.tcl: Made the initialization of the compatibility system a bit more robust against loading it multiple times. 2006-09-11 Will Duquette * main2.tcl: Comp.statement.typevariable now places the type name directly in the "tvprocdec" rather than waiting to substitute it in later. 2006-08-19 Will Duquette * main2.tcl, snit.test: Fixed Bug 1483168: "Namespaced snit objs are not commands in their ns". In particular, Snit 2.x types and widgets now use [namespace path] to give themselves access to their parent namespace. * snit.man,snitfaq.man: Updated accordingly; also, fixed a couple of typos in snitfaq.man. * main2.tcl: Snit 2.x now uses [namespace upvar] where appropriate throughout the Snit run-time and also for implicit declaration of instance variables; I still need to use it for implicit declaration of type variables. On my machine, dispatch of a method with 10 instance variables is over twice as fast when the variables are declared using [namespace upvar] rather than [::variable ${selfns}::varname]. * main2.tcl: Snit 2.x now uses [namespace upvar] for implicit declaration of type variables as well. It develops that [namespace upvar] is a lot faster than [::variable] even when using the default namespace (e.g., "::variable varname"). 2006-08-15 Will Duquette * main2.tcl, snit.test: Fixed Bug 1532791: "snit2, snit::widget problem". 2006-08-12 Will Duquette * main1.tcl, main1_83.tcl, main2.tcl: Replaced as many [string equal] calls in main1_83.tcl with {"" ==/!= $a} expressions, so that the differences between the two files are minimized. Also removed the "-glob" from calls to "array names" in main1.tcl. There are now only a few remaining differences between the two files. Also, I added a "return" to the end of RT.DestroyObject in all three "main" modules, to prevent a confusing return value from "$object destroy" that Andreas noticed a while back. * snit.test: Two tests, iinfo-6.4 and iinfo-6.5, failed on Tcl 8.3. The -result in both cases was a list of Tk widget options that included some new options defined in Tcl 8.4. I added two new constraints, tcl83 and tcl84, and duplicated the two tests, one for each. 2006-08-10 Will Duquette * snit.man: Added documentation for how to define new validation types. 2006-08-09 Will Duquette * snit.man: Added documentation for the "-type" option-definition option, and for the validation types. I still need to fill in a section on defining new validation types. * validate.tcl: Cleaned up the header comment. 2006-08-08 Will Duquette * main1.tcl: Removed all "eq" and "ne" expressions, to reduce the differences between main1.tcl and main1_83.tcl. Unlike main1_83.tcl, though, I used the forms {"" == $a} and {"" != $a} in preferences to [string equal], as they are both shorter and more efficient. I used [string equal] only when comparing two variables. The next step is to update main1_83.tcl to use the {"" ==/!= $a} form where possible, in preference to [string equal]; then, most of the code can be shared between the two modules, which will simplify maintenance. 2006-08-07 Will Duquette * Implemented "-type" option-definition option in main2.tcl, for Snit 2.x, and main1_83.tcl for Snit 1.2 on Tcl 8.3. 2006-08-06 Will Duquette * Major reorganization of the code modules. snit.tcl and snit2.tcl are now just short loader scripts. The Snit 1.x compiler and run-time library are implemented in main1.tcl and main1_83.tcl, respectively; the Snit 2.x compiler and run-time are in main2.tcl. Both loaders load validate.tcl, which contains the new validation types. This scheme is documented in modules.txt. * Bumped the Snit 1.x version number to Snit 1.2, since Snit 1.1 has been a robust, stable release. * snit83.tcl: Removed; obsolete * snit84.tcl: Removed; obsolete * snit.tcl, main1_83.tcl: snit_tcl83_utils.tcl is now sourced in snit.tcl rather than main1_83.tcl. I don't believe this should cause a problem....but it needs to be tested. * snit.test: Added tests for Snit validation types. These tests pass for Snit 2.x and for Snit 1.2 with Tcl 8.4. They *should* pass for Snit 1.2 with Tcl 8.3, but I've been unable to test that. * README.txt: Updated * main1.tcl, snit.test: Implemented the "-type" option-definition option for Snit 1.2 and Tcl 8.4, and added related tests. * Still to do: 1. Implement the "-type" option-definition option in main1_83.tcl and main2.tcl. 2. Write documentation for "-type" and for the Snit validation types. 3. Consider refactoring main1.tcl, main1_83.tcl for maximum commonality, to simplify future changes of this kind. 2006-08-05 Will Duquette * validate.tcl: New module; defines a number of "validation types". These will be used with the forthcoming "-type" option-definition option to add robust validation for snit::type and snit::widget options. 2006-07-26 Andreas Kupries * snitfaq.man: Finally fixed the two ambigous section titles. 2006-01-30 Andreas Kupries * snit.tcl: Fixed [SF Tcllib Bug 1414589], prevent the package activation code from stomping on the global variable 'dir'. 2006-01-29 Andreas Kupries * snit.test: Fixed use of duplicate test names. Whitespace police as well. 2006-01-26 Andreas Kupries * snit.test: More boilerplate simplified via use of test support. 2006-01-19 Andreas Kupries * snit.test: Hooked into the new common test support code. Reactivated the tests based on the commands wrongNumArgs and tooManyArgs. Coming out of the new test support code. 2006-01-14 Will Duquette * snit2.tcl (::snit::RT.UnknownMethod): When creating a new submethod ensemble, creates it in the ${selfns} namespace instead of in the ${type} namespace (fix courtesy of Anton Kovalenko). Previously, multiple objects of a type that defines a submethod ensemble would share a single ensemble, with confusing results. * snit.test: Added test hmethod-1.6, to test for the above error. As expected, there was no error in snit 1.1, but the test failed in snit 2.0 until the above change was made. * snit.test: "if 0"'d out some tests that make use of tcltest::tooManyArgs and tcltest::wrongNumArgs, two commands that aren't available to me. * snitfaq.man: Fixed a typo and added a suggestion from Andreas Kupries on how to name component commands. * snit.man: Added Kenneth Green and Anton Kovalenko to the list of names in the "Credits". 2005-12-05 Andreas Kupries * snit83.tcl: Replaced the direct use of / path separator with a proper file join. 2005-11-07 Andreas Kupries * pkgIndex.tcl: Moved the selection of the implementation out of the package declaration into the runtime. * snit.tcl: Renamed to snit84.tcl. Also a new file containing the selection of the implementation, basic dependency, and common provide command. * snit84.tcl: New file. Was originally named 'snit.tcl'. Contains the Tcl 8.4 specific implementation of the package. * snit.test: Updated to new entrypoint for snit 1.1. 2005-10-06 Andreas Kupries * * Released and tagged Tcllib 1.8 ======================== * 2005-09-26 Andreas Kupries * snit.test: Adapted the testsuite to handle the 8.3 backport. * snit83.tcl: Integrated Kenneth Green's backport of * snit_tcl83_utils.tcl: Snit to Tcl 8.3 into the code base. * snit.tcl: Checking the list result of [info commands ] now using [llength] instead of string comparisons. * snit2.tcl: Checking the list result of [info commands ] now using [llength] instead of string comparisons. 2005-09-05 Will Duquette * snitfaq.man: Updated for Snit 2.0/1.1. 2005-08-27 Will Duquette * snit.man: Updated for Snit 2.0/1.1 * snit.tcl: Added the new hulltypes to snit.tcl (somehow they didn't get in). * snit.test: Added a test that verifies the list of valid hulltypes. 2005-08-22 Jeff Hobbs * snit.tcl, snit2.tcl: allow labelframe and ttk::labelframe as hulltypes, and tk::(label)frame (planning ahead ...) 2005-08-20 Will Duquette * snit.tcl: It's now an error to call an object's "destroy" method in the object's constructor. * snit2.tcl: Snit 2.0, implemented with "namespace ensemble". * snit.test: Now uses the "-body" style of Tcltests throughout. Also, tests Snit 1.x (snit.tcl) when run with Tcl/Tk 8.4, and tests Snit 2.x when run with Tcl/Tk 8.5. 2005-08-10 Jeff Hobbs * snit.tcl (::snit::Comp.statement.hulltype): make hulltype one of $::snit::hulltypes, allow ttk::frame 2005-06-07 Will Duquette * snit.test (bug-2.1, bug-2.2): Added the "tk" constraint, so that they'll be excluded when snit.test is run with tclsh. 2005-06-04 Will Duquette * snit.tcl, snit.man, snitfaq.man: Updated the copyright information to 2005. * snit.html, faq.html: Removed these files, as they are obsolete. snit.man and snitfaq.man contain the up-to-date documentation. 2005-06-04 Will Duquette * snit.tcl: Bumped the version number to 1.0 * pkgIndex.tcl: Bumped the version number to 1.0. * dictionary.txt: Bumped the version number to 1.0. * snit.man: Bumped the version number to 1.0. * snitfaq.man: Bumped the version number to 1.0. 2005-06-04 Will Duquette * snit.tcl (::snit::RT.DestroyObject) * snit.test (test bug-2.1, bug-2.2): Fixed [SF Tcllib Bug 1106375]. 2005-06-04 Will Duquette * snit.tcl (::snit::Comp.statement.destructor): * snit.test (test bug-1.1) Fixed [SF Tcllib Bug 1161779]. 2005-06-04 Will Duquette * snit.tcl: Checked a number of small optimizations Jeff Hobbs sent me. Bumped the version number to 0.98. * pkgIndex.tcl: Bumped the version number to 0.98. * dictionary.txt: Bumped the version number to 0.98. * snit.man: Bumped the version number to 0.98. * snitfaq.man: Bumped the version number to 0.98. 2005-04-11 Marty Backe * snit.man: Fixed typo in the -configuremethod example. 2005-02-14 Andreas Kupries * snitfaq.man: Fixed a number of typos reported by Bob Techentin, see [SF Tcllib Bug 1050674]. 2004-10-05 Andreas Kupries * * Released and tagged Tcllib 1.7 ======================== * 2004-09-23 Andreas Kupries * snit.test: Fixed the tests which were dependent on the exact order of results returned by [array names]. Which failed for Tcl 8.5. Added lsort and updated expected results, for canonical comparison. 2004-09-18 Will Duquette * snit.man: Documented hierarchical methods and typemethods. * Everything: Updated version to 0.97. 2004-09-16 Will Duquette * snit.tcl In "component foo -public name", the "-public name" part is now implemented as "delegate method {name *} to foo". * snit.test Added tests for "$type info typemethods", "$self info typemethods" and "$self info methods" for the case of hierarchical methods/typemethods, and fixed related bugs in snit.tcl. 2004-09-14 Will Duquette * snit.tcl Modified the implementation of hierarchical methods; * snit.test this involved extending the syntax of method "using" patterns to better support the hiearchical case. * snit.tcl Extended the "delegate method *" and * snit.test "delegate typemethod *" syntax to work better with hierarchical methods. E.g., "delegate method {tail *} to tail" now maps "$self tail wag" to "$tail wag" 2004-09-12 Will Duquette * snit.tcl Added support for hierarchical type methods, * snit.test analogously to the support for regular methods. * README.txt * snit.tcl Refactored the compilation of hierarchical * snit.test methods and typemethods to remove duplicated code. 2004-09-10 Will Duquette * snit.tcl Added support for hierarchical methods: methods * snit.test with submethods. The documentation has not yet * README.txt been updated. * snit.tcl Bug fix: "delegate method {a b} to comp" now produces * snit.test the call "$comp a b" instead of "$comp a_b". 2004-09-04 Will Duquette * snit.tcl Bug fix: read-only options were read-only only * snit.test if they weren't set at creation time; the * README.txt configure cache wasn't being cleared properly after creation. 2004-08-28 Will Duquette * snit.tcl: Minor tweaks to instance creation to improve * dictionary speed. No major gain. Also, -simpledispatch yes * snit.man now supports instance renaming again. * snitfaq.man 2004-08-22 Will Duquette * snit.tcl Defined the -simpledispatch pragma. Updated * snit.test the test suite and the relevant documentation. * snit.man * README.txt * snitfaq.man * dictionary 2004-08-14 Will Duquette * snit.tcl Defined the -hastypemethods pragma, and added * snit.test relevant tests and documentation. * snit.man * README.txt * snitfaq.man 2004-08-12 Will Duquette * snit.tcl Under appropriate conditions, calling a * snit.test snit::type command with no arguments will create * snit.man an instance with an automatically generated name. * README.txt 2004-08-11 Will Duquette * snit.tcl Added the -hasinfo pragma, along with the * snit.test appropriate tests. Updated documentation. * snit.man * README.txt * snit.tcl The "configure", "configurelist" and "cget" * snit.test instance methods, along with the "options" * snit.man instance variable, are defined only if the * README.txt type defines at least one option (either locally or by delegation). 2004-08-07 Will Duquette * All files Updated to Snit V0.96 for post-0.95 development. Fixed bug: methods called via [mymethod] can now return exotic return codes, e.g., "return -code break" 2004-08-04 Will Duquette * snitfaq.man Updated the Snit FAQ document. * snit.man Finalized Snit V0.95, and updated the version number * snit.tcl throughout. * pkgIndex.tcl * README.txt 2004-07-27 Will Duquette * snit.man Updated the manpage to describe the new "pragma" statement. Also, changed the SNIT acronym in the title to "Simple Now In Tcl", i.e., objects are now simple. * snit.tcl Added another pragma, -canreplace. If false * snit.test (the default) snit::types can no longer create * README.txt instances which replace existing Tcl commands. * snit.man Setting "pragma -canreplace yes" restores the * dictionary previous behavior. * snit.tcl The type definition statements "variable" and * snit.test "typevariable" now take a "-array" option that * README.txt allows them to initialize array variables with * snit.man an "array set" list. * snit.test Fixed Snit bug 899207 (snit test failures) * snit.tcl Added new instance introspection methods * snit.test "info typemethods" and "info methods", and a new * README.txt type introspection typemethod "info typemethods". * snit.man * roadmap.txt * snit.man Reviewed the entire man page, and made copious changes and fixes. * snit.tcl Revised many of the error messages to be more * snit.test Tcl/Tk-like. Double-quotes are used instead of single quotes, and terminal periods are omitted. * snit.tcl Added some code to method and typemethod dispatch * snit.test so that the return code (e.g., return -code break) returned by the method/typemethod code is passed along unchanged. This is mostly so that methods and typemethods can conditionally break in event bindings. 2004-07-26 Will Duquette * snit.tcl Implemented -configuremethod and configure command * snit.test caching; added tests to ensure that the cache is * roadmap.txt cleared when necessary. Implemented -validatemethod * dictionary and added tests. Implemented -readonly and added * README.txt tests. * snit.man Updated the man page with the new option definition syntax. * snit.tcl Added the "pragma" statement, and three pragma * snit.test options, -hastypeinfo, -hastypedestroy, and * roadmap.txt -hasinstances, plus related tests. It still * dictionary needs to be documented. 2004-07-25 Will Duquette * snit.tcl Renamed some procs for clarity, and repaired some * roadmap.txt omissions in roadmap.txt. Added "cget" command * snit.test caching for additional speed-up. * dictionary.txt 2004-07-24 Will Duquette * snit.tcl (::snit::RT.MethodCacheLookup): The cached command is now generated as a list, not a string; this improves the speed of method invocation by quite a bit. 2004-07-24 Will Duquette * snit.tcl Consolidated the option typevariables into a * dictionary single array, Snit_optionInfo. Implemented * roadmap.txt parsing of the new option definition syntax; * snit.test the -validatemethod, -configuremethod, and -cgetmethod options as yet have no effect. Added tests to ensure that the 'option' and 'delegate option' statements populate Snit_optionInfo properly. Added "starcomp" to the Snit_optionInfo array. When "delegate option *" is used, "*" no longer has a "target-$opt" entry, nor does it appear in "delegated-$comp". Instead, "starcomp" is the name of the component to which option "*" is delegated, or "". Reimplemented user-defined "cget" handlers using the "-cgetmethod" option definition option. The "oncget" statement now defines a method, and sets the option. 2004-07-21 Will Duquette * README.txt Updated to reflect recent changes. * snit.man 2004-07-20 Will Duquette * snit.tcl Finished the refactoring job. All extraneous * roadmap.txt code has been moved from the type templates to the ::snit:: runtime. 2004-07-19 Will Duquette * snit.tcl Refactored %TYPE%::Snit_optionget to * roadmap.txt ::snit::RT.OptionDbGet. Refactored %TYPE%::Snit_cleanup to ::snit::RT.DestroyObject, %TYPE%::Snit_tracer to ::snit::RT.InstanceTrace, and %TYPE%::Snit_removetrace to ::snit::RT.RemoveInstanceTrace. 2004-07-17 Will Duquette * snit.tcl Added "delegate typemethod ..." in all its glory, * snit.test including "delegate typemethod *". Made it * dictionary.txt Possible to delegate an instance method to a * roadmap.txt typecomponent. Added tests to ensure that variable/typevariable and component/typecomponent names do not collide. Updated a number of compilation error messages for consistency. Moved the remaining typemethod definitions from the template code and replaced them delegations to the Snit runtime library. Added/modified relevant tests, and updated the roadmap and dictionary files. 2004-07-15 Will Duquette * snit.tcl Replaced the old typemethod definition and cacheLookup code with new pattern-based code, just like the method definition and lookup. The cache lookup routine doesn't yet understand typemethod "*". The next step is to implement typecomponents and "delegate typemethod". * dictionary.txt Documented the changes related to the above change. 2004-07-14 Will Duquette * snit.tcl Replaced %TYPE%::Snit_comptrace with snit::RT.ComponentTrace. Replaced %TYPE%::Snit_cacheLookup with snit::RT.MethodCacheLookup Replaced %TYPE%::Snit_typeCacheLookup with snit::RT.TypemethodCacheLookup * snit.test Added a test to verify that a widget's hull component cannot be altered once it is set. * roadmap.txt Documents the internal structure of snit.tcl. 2004-07-11 Will Duquette * snit.tcl Renamed a number of internal commands, for clarity. Refactored the standard method bodies out of the type definition and into the Snit runtime using delegation. Defined snit::compile which compiles a type definition into the Tcl script which actually defines the type. * snit.test Added and modified appropriate tests. * README.txt Added a bullet about snit::compile. 2004-07-05 Will Duquette * snit.tcl Replaced the old method cacheLookup code with new code based on command patterns. All tests pass; no test changes were needed. All is now ready to add the new "delegate method" "using" keyword. * dictionary.txt This file documents Snit's private variables. It's up-to-date, and checked in for the first time. * snit.tcl Implemented the new "using " clause to * snit.test "delegate method", and added relevant tests. * snit.man Documented the new "delegate method" syntax. * README.txt 2004-07-04 Will Duquette * snit.tcl Re-implemented the option and method delegation * snit.test syntax so that the order of clauses is no longer important. Along the way, I made the relevant error messages more specific. 2004-06-26 Will Duquette * snit.tcl Added the "component" statement, with two options, * snit.test -public and -inherit. Added all relevant tests. * snit.man Updated the man page to describe it. 2004-05-30 Will Duquette * snit.man Updated per 0.94 changes to date; also I made a sweep through the whole document and cleaned things up here and there for readability. 2004-05-29 Will Duquette * snit.tcl Moved Snit_component to snit::Component. Removed the "type" argument from all of the "Type.*" procs. Instead, the compilation type is available as $compile(type). Consequently, the Type.* procs can now be aliased into the compiler just once, instead of with every type definition. (Did that.) Defined snit::macro. * snit.test Added tests for snit::macro. 2004-05-23 Andreas Kupries * * Released and tagged Tcllib 1.6.1 ======================== * 2004-05-15 Will Duquette * snit.tcl: Updated version to 0.94 * pkgIndex.tcl: * snit.tcl: Modified the Snit_dispatcher function to use a method command cache. Method commands are assembled in Snit_cacheLookup only if they aren't found in the cache. The new Snit_dispatcher was much shorter, so its code was moved into the object's instance command, and Snit_dispatcher was deleted altogether. These changes speed up method calls considerably. Snit_tracer was then modified to clear the method cache when the instance command is renamed--the cached commands contained the old instance command name. * snit.test: Components can be changed dynamically; the method cache breaks this, because the previous component's command is still cached. Added a test that checks whether the method cache is cleared properly when a component is changed. * snit.tcl: Snit_comptrace now clears the method cache when a component is redefined. * snit.tcl: Added a type method cache. Type methods (with the exception of implicit "create") are now as fast as instance methods. This is a naive implementation, though--for typemethods, the cache could be populated at definition time, since there's no delegation. Of course, if I added typemethod delegation then what I'm doing is appropriate. * snit.tcl: Reorganized some things, in preparation to move shared code from the type definition to the snit:: namespace. * snit.tcl: Made %TYPE%::mymethod an alias to snit::MyMethod. * snit.tcl: Added %TYPE%::myproc, as an alias to * snit.test: snit::MyProc. "codename" is now deprecated. Added tests for myproc. * snit.tcl: %TYPE%::codename is now an alias to snit::CodeName. * snit.tcl: Added %TYPE%::myvar and %TYPE%::mytypevar; these replace %TYPE%::varname and %TYPE%::typevarname, which are now deprecated. All are now implemented as aliases to calls in snit::. * snit.tcl: %TYPE%::variable is now an alias to snit::variable. * snit.tcl: %TYPE%::from is now an alias to snit::From. 2004-02-26 Andreas Kupries * snit.test: Codified the requirement of Tcl 8.4 into * pkgIndex.tcl: package index and test suite. 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * 2004-02-07 Will Duquette * README.txt: Added 0.93 information to README.txt. * snit.tcl: Fixed bug: "$obj info vars" used to leave out "options" * snit.test: if no options were defined. It's clearer if the behavior is always the same. Fixed tcllib bugs item #852945: variable. The statement "variable ::my::qualified::name" in an instance method now makes "name" available, just as the standard "variable" command does. Fixed bug: in some cases the type command was created even if there was an error defining the type. The type command is now cleaned up in these cases. (Credit Andy Goth) * snit.tcl: Implemented RFE 844766: need ability to split class * snit.test: defs across files. Added the snit::typemethod and * snit.html: snit::method commands; these allow typemethods and methods to be defined after the class already exists. 2004-02-07 Will Duquette * All: Updated version to 0.93. * snit.tcl: The %AUTO% name counter wraps around to 0 when it reaches 2^31 - 1, to prevent integer overflow errors. * snit.html: Minor corrections and updates. * faq.html 2003-12-06 Will Duquette * All: Updated version to 0.92. * snit.tcl Snit now propagates errorCode properly when * snit.test propagating errors. 2003-12-01 Andreas Kupries * snit.man: Updated to changes in the .html files. * snitfaq.man: 2003-11-21 Will Duquette * snit.tcl: Updated version to 0.91. * pkgIndex.tcl: * snit.tcl: Added the "expose" statement to type and widget definitions. * snit.test: Added appropriate tests. * snit.html: Added documentation for "expose". * faq.html: Updated the FAQ entries. * snit.tcl: Added "string match" patterns to the Snit info methods. * snit.test: Added appropriate tests. * snit.html: Updated documentation. 2003-10-28 Andreas Kupries * snit.man: Fixed typos in documentation. * snitfaq.man: 2003-10-27 Will Duquette * snit.html: Fixed typos in documentation. * faq.html: 2003-10-27 Andreas Kupries * snit.man: Updated to changes in the .html files. * snitfaq.man: 2003-10-25 Will Duquette * snit.tcl: Added the "except" clause for "delegate method *" and * snit.test: "delegate option *". This allows the user to explicitly exclude certain methods and options. Added appropriate tests. * snit.html: Gave the Snit FAQ a bit of an overhaul, and added * faq.html: information corresponding to the recent code changes, including a great deal of material on Snit and the Tk option database. Updated the Snit man page to be consistent with the recent code changes. 2003-10-23 Andreas Kupries * snit.man: Updated from Will's html doc's. 2003-10-23 Will Duquette * snit.html: Added documentation for the new "hulltype", "widgetclass", and "install" commands. Updated the documentation for "installhull" to show the new "installhull using" syntax. Updated the documentation for "option" and "delegate option" to show how to specify the resource and class names for options. Added a section on the interaction between Snit and the Tk option database. 2003-10-21 Will Duquette * snit.tcl: Add the "hulltype" command. This allows the snit::widget * snit.test: author to choose whether the hull should be a frame or a toplevel. Tests have been updated as usual. 2003-10-20 Will Duquette * snit.tcl: The new "install" command can now be used to install * snit.test: components for snit::types as well. It doesn't add any value, since there's no option database, but at least the syntax will be the same. "install" now initializes the component properly from the option database when "option *" has been delegated to it. Tests have been updated as usual. 2003-10-19 Will Duquette * snit.tcl: During normal widget creation, the default values * snit.test: for a widget's local options are overridden by values from the option database. Array %TYPE%::Snit_compoptions now lists delegated option names for each component. Added a new command, "install", for use in widget and widgetadaptor constructors. Install creates a widget, assigning it to a component; it also queries the option database for any option values that are delegated to this component. Modified installhull, adding a new form that queries the option database as appropriate for options delegated to the hull widget. At this point, the only options whose default values do not come from the option database in the proper way are those implicitly delegated by "delegate option *" to a non-hull widget. I need to think about those. Of course, new tests have been added for all of this. The version number in snit.tcl has been updated to 0.84. 2003-10-18 Will Duquette * snit.tcl: Added the "widgetclass" statement; this allows * snit.test: snit::widgets (and nothing else) to explicitly set the widget class name passed to the hull as "-class". In addition, the hull's -class is set automatically, to the explicit widgetclass, if any, or to the widget type name with an initial capital letter. Next, an object's options now have real resource and class names, which are reported correctly by "$obj configure". By default, the resource name is just the option name minus the hyphen, and the class name is just the resource name with an initial capital. In both the "option" and "delegate option" statements, the option name may be specified as a pair or a triple, e.g., option {-name name Name} Thus, the resource name and class name can be specified explicitly. In previous versions, the resource name and class name returned by configure for delegated options was the resource name and class name returned by the component. This is no longer true; configure now returns the resource and class name defined in the type definition. 2003-10-17 Will Duquette * snit.html: Added typeconstructor documentation. * faq.html: * snit.tcl: Implemented typeconstructors. A typeconstructor's body is executed as part of the compiled type definition; it has access to all of the typevariables and typemethods. Its job is to initialize arrays, set option database values, and like that. * snit.test: Added tests for typeconstructors. 2003-10-16 Will Duquette * README.txt: Updated to reflect snit's presence in tcllib, and to point to this ChangeLog file. 2003-09-30 Andreas Kupries * snit.tcl: A number of changes to the code generation part. - Usage of [subst]'s was superfluous, removed, simple string interpolation now. - Now 'namespace eval type' enclosing the generated code anymore. Such an eval is now done only at the top of the generated code to define the namespace, and to define/initialize the typevariables. All procedure definitions are now outside of 'namespace eval' and use fully qualified command names instead. - Moved the code in [snit::Define] which instantiated the class using the generated code into it own helper command, [snit::DefineDo]. Overiding this command allows users of the snit package perform other actions on the newly defined class. One example is that of a snit-compiler which goes through a file containing tcl code and replaces all snit::* definitions with the generated code. Motivation for the change: When applying procomp to procedure definitions inside of a 'namespace eval' they are not byte-compiled, but kept as encoded literal. This is a direct consequence of 'namespace eval' not having a compile function. It also means that introspection, i.e. [info body] does recover the actual procedure definition. By using procedure definitions outside of namespace eval, but fully qualified names this limitation of procomp is avoided. The aforementioned snit compiler application is another part for this, ensuring that instead of keeping the whole class definition as one literal for the snit::* call we actually have tcl code to compile and hide. * snit.tcl: Updated the version number to 0.83 * pkgIndex.tcl: * snit.man: * snitfaq.man: 2003-07-18 Andreas Kupries * snit.test: Fixed SF tcllib bug #772535. Instead of using a * snit.tcl: variable reference in the callback a regular command is called, with the unchanging 'selfns' as argument. From there things go through the regular dispatching mechanism after the actual instance name was obtained. Updated all affected tests. Updated dmethod-1.5 also, 'string' delivers a different error message. 2003-07-16 Andreas Kupries * snit.man: Added references to bug trackers, as part of * snitfaq.man: caveats. Also added note about bwidget/snit interaction. * snit.tcl: Integrated latest (small) change to original code base (was not released yet). Removes bad trial to fix up error stack. We are now at version 0.82. Added note to developers explaining the catch in Snit_tracer. 2003-07-15 Andreas Kupries * snit.tcl: Imported new module into tcllib. * snit.test: snit = Snit Is Not IncrTcl * snit.html: Author: William Duquette * faq.html: OO package + megawidget framework. * README.txt: * license.txt: * pkgIndex.tcl: * snit.man: * snitfaq.man: tcltk2/inst/tklibs/snit2.3.4/README.txt0000644000176200001440000007715215017041713016775 0ustar liggesusersSnit's Not Incr Tcl README.txt ----------------------------------------------------------------- Snit is pure-Tcl object and megawidget framework. See snit.html for full details. Snit is part of "tcllib", the standard Tcl Library. Snit lives in "tcllib" now, but it is available separately at http://www.wjduquette.com/snit. If you have any questions, bug reports, suggestions, or comments, feel free to contact me, Will Duquette, at will@wjduquette.com; or, join the Snit mailing list (see http://www.wjduquette.com/snit for details). Differences Between Snit 2.1 and Snit 1.x -------------------------------------------------------------------- V2.0 and V1.x are being developed in parallel. Version 2.1 takes advantage of some new Tcl/Tk 8.5 commands ([dict], [namespace ensemble], and [namespace upvar]) to improve Snit's run-time efficiency. Otherwise, it's intended to be feature-equivalent with V1.x. When running with Tcl/Tk 8.5, both V2.0 and V1.x are available; when running with Tcl/Tk 8.3 or Tcl/Tk 8.4, only V1.x is available. Snit 1.x is implemented in snit.tcl; Snit 2.1 in snit2.tcl. V2.1 includes the following enhancements over V1.x: * A type's code (methods, type methods, etc.) can now call commands from the type's parent namespace without qualifying or importing them, i.e., type ::parentns::mytype's code can call ::parentns::someproc as just "someproc". This is extremely useful when a type is defined as part of a larger package, and shares a parent namespace with the rest of the package; it means that the type can call other commands defined by the package without any extra work. This feature depends on the new Tcl 8.5 [namespace path] command, which is why it hasn't been implemented for V1.x. V1.x code can achieve something similar by placing namespace import [namespace parent]::* in a type constructor. This is less useful, however, as it picks up only those commands which have already been exported by the parent namespace at the time the type is defined. There are four incompatibilities between V2.1 and V1.x: * Implicit naming of objects now only works if you set pragma -hastypemethods 0 in the type definition. Otherwise, set obj [mytype] will fail; you must use set obj [mytype %AUTO%] * In Snit 1.x and earlier, hierarchical methods and type methods could be called in two ways: snit::type mytype { method {foo bar} {} { puts "Foobar!"} } set obj [mytype %AUTO%] $obj foo bar ;# This is the first way $obj {foo bar} ;# This is the second way In Snit 2.1, the second way no longer works. * In Snit 1.x and earlier, [$obj info methods] and [$obj info typemethods] returned a complete list of all known hierarchical methods. In the example just above, for example, the list returned by [$obj info methods] would include "foo bar". In Snit 2.1, only the first word of a hierarchical method name is returned, [$obj info methods] would include "foo" but not "foo bar". * Because a type's code (methods, type methods, etc.) can now call commands from the type's parent namespace without qualifying or importing them, this means that all commands defined in the parent namespace are visible--and can shadow commands defined in the global namespace, including the standard Tcl commands. There was a case in Tcllib where the Snit type ::tie::std::file contained a bug with Snit 2.1 because the type's own name shadowed the standard [file] command in the type's own code. Changes in V1.2 -------------------------------------------------------------------- * Defined a family of validation types. Validation types are used to validate data values; for example, snit::integer and its subtypes can validate a variety of classes of integer value, e.g., integers between 3 and 9 or integers greater than 0. Changes in V1.1 -------------------------------------------------------------------- * It's now explicitly an error to call an object's "destroy" method in the object's constructor. (If you need to do it, just throw an error; construction will fail and the object will be cleaned up. * The Tile "ttk::frame" widget is now a valid hulltype for snit::widgets. Any widget with a -class option can be used as a hulltype; lappend the widget name to snit::hulltypes to enable its use as a hulltype. * The TK labelframe widget and the Tile ttk::labelframe widget are now valid hulltypes for snit::widgets. Changes in V1.0 -------------------------------------------------------------------- Functionally, V1.0 is identical to version V0.97. * Added a number of speed optimizations provided by Jeff Hobbs. (Thanks, Jeff!) * Returned to the name "Snit's Not Incr Tcl". * Fixed SourceForge Tcllib Bug 1161779; it's no longer an error if the destructor is defined before the constructor. * Fixed SourceForge Tcllib Bug 1106375; the hull widget is now destroyed properly if there's an error in the constructor of a widget or widgetadaptor. Changes in V0.97 -------------------------------------------------------------------- The changes listed here were actually made over time in Snit V0.96; now that they are complete, the result has been renumbered Snit V0.97. * Bug fix: methods called via [mymethod] can now return exotic return codes (e.g., "return -code break"). * Added the -hasinfo pragma, which controls whether there's an "info" instance method or not. By default, there is. * POSSIBLE INCOMPATIBILITY: If no options are defined for a type, neither locally nor delegated, then Snit will not define the "configure", "configurelist", and "cget" instance methods or the "options" instance variable. * If a snit::type's command is called without arguments, AND the type can have instances, then an instance is created using %AUTO% to create its name. E.g., the following commands are all equivalent: snit::type dog { ... } set mydog [dog create %AUTO%] set mydog [dog %AUTO%] set mydog [dog] This doesn't work for widgets, for obvious reasons. * Added pragma -hastypemethods. If its value is "yes" (the default), then the type has traditional Snit behavior with respect to typemethods. If its value is "no", then the type has no typemethods (even if typemethods were included explicitly in the type definition). Instead, the first argument of the type proc is the name of the object to create. As above, the first argument defaults to "%AUTO%" for snit::types but not for snit::widgets. * Added pragma -simpledispatch. This pragma is intended to make simple, heavily used types (e.g. stacks or queues) more efficient. If its value is "no" (the default), then the type has traditional Snit behavior with respect to method dispatch. If its value is "yes", then a simpler, faster scheme is used; however, there are corresponding limitations. See the man page for details. * Bug fix: the "pragma" statement now throws an error if the specified pragma isn't defined, e.g., "pragma -boguspragma yes" is now an error. * Bug fix: -readonly options weren't. Now they are. * Added support for hierarchical methods, like the Tk text widget's tag, mark, and image methods. You define the methods like so: method {tag add} {args} {...} method {tag configure} {args} {...} method {tag cget} {args} {...} and call them like so: $widget tag add .... The "delegate method" statement also supports hierarchical methods. However, hierarchical methods cannot be used with -simpledispatch. * Similarly, added support for hierarchical typemethods. Changes in V0.96 -------------------------------------------------------------------- V0.96 was the development version in which most of the V0.97 changes were implemented. The name was changed to V0.97 when the changes were complete, so that the contents of V0.97 will be stable. Changes in V0.95 -------------------------------------------------------------------- The changes listed here were actually made over time in Snit V0.94; now that they are complete, the result has been renumbered Snit V0.95. * Snit method invocation (both local and delegated) has been optimized by the addition of a "method cache". The primary remaining cost in method invocation is the cost of declaring instance variables. * Snit typemethod invocation now also uses a cache. * Added the "myproc" command, which parallels "mymethod". "codename" is now deprecated. * Added the "mytypemethod" command, which parallels "mymethod". * Added the "myvar" and "mytypevar" commands. "varname" is now deprecated. * Added ::snit::macro. * Added the "component" type definition statement. This replaces "variable" for declaring components explicitly, and has two nifty options, "-public" and "-inherit". * Reimplemented the "delegate method" and "delegate option" statements; among other things, they now have more descriptive error messages. * Added the "using" clause to the "delegate method" statement. The "using" clause allows the programmer to specify an arbitrary command prefix into which the component and method names (among other things) can be automatically substituted. It's now possible to delegate a method just about any way you'd like. * Added ::snit::compile. * Added the "delegate typemethod" statement. It's similar to "delegate method" and has the same syntax, but delegates typemethods to commands whose names are stored in typevariables. * Added the "typecomponent" type definition statement. Parallel to "component", "typecomponent" is used to declare targets for the new "delegate typemethod" statement. * "delegate method" can now delegate methods to components or typecomponents. * The option definition syntax has been extended; see snit.man. You can now define methods to handle cget or configure of any option; as a result, The "oncget" and "onconfigure" statements are now deprecated. Existing "oncget" and "onconfigure" handlers continue to function as expected, with one difference: they get a new implicit argument, "_option", which is the name of the option being set. If your existing handlers use "_option" as a variable name, they will need to be changed. * In addition, the "option" statement also allows you to define a validation method. If defined, it will be called before the value is saved; its job is to validate the option value and call "error" if there's a problem. * In addition, options can be defined to be "-readonly". A readonly option's value can be set at creation time (i.e., in the type's constructor) but not afterwards. * There's a new type definition statement called "pragma" that allows you to control how Snit generates the type from the definition. For example, you can disable all standard typemethods (including "create"); this allows you to use snit::type to define an ensemble command (like "string" or "file") using typevariables and typemethods. * In the past, you could create an instance of a snit::type with the same name as an existing command; for example, you could create an instance called "::info" or "::set". This is no longer allowed, as it can lead to errors that are hard to debug. You can recover the old behavior using the "-canreplace" pragma. * In type and widget definitions, the "variable" and "typevariable" statements can now initialize arrays as well as scalars. * Added new introspection commands "$type info typemethods", "$self info methods", and "$self info typemethods". * Sundry other internal changes. Changes in V0.94 -------------------------------------------------------------------- V0.94 was the development version in which most of the V0.95 changes were implemented. The name was changed to V0.95 when the changes were complete, so that the contents of V0.95 will be stable. Changes in V0.93 -------------------------------------------------------------------- * Enhancement: Added the snit::typemethod and snit::method commands; these allow typemethods and methods to be defined (and redefined) after the class already exists. See the Snit man page for details. * Documentation fixes: a number of minor corrections were made to the Snit man page and FAQ. Thanks to everyone who pointed them out, especially David S. Cargo. * Bug fix: when using %AUTO% to create object names, the counter will wrap around to 0 after it reaches (2^32 - 1), to prevent integer overflow errors. (Credit Marty Backe) * Bug fix: in a normal Tcl proc, the command variable ::my::namespace::var makes variable "::my::namespace::var" available to the proc under the local name "var". Snit redefines the "variable" command for use in instance methods, and had lost this behavior. (Credit Jeff Hobbs) * Bug fix: in some cases, the "info vars" instance method didn't include the "options" instance variable in its output. * Fixed bug: in some cases the type command was created even if there was an error defining the type. The type command is now cleaned up in these cases. (Credit Andy Goth) Changes in V0.92 -------------------------------------------------------------------- * Bug fix: In type methods, constructors, and methods, the "errorCode" of a thrown error was not propagated properly; no matter what it was set to, it always emerged as "NONE". Changes in V0.91 -------------------------------------------------------------------- * Bug fix: On a system with both 0.9 and 0.81 installed, "package require snit 0.9" would get snit 0.81. Here's why: to me it was clear enough that 0.9 is later than 0.81, but to Tcl the minor version number 9 is less than minor version number 81. From now on, all pre-1.0 Snit version numbers will have two digits. * Bug fix: If a method or typemethod had an argument list which was broken onto multiple lines, the type definition would fail. It now works as expected. * Added the "expose" statement; this allows you to expose an entire component as part of your type's public interface. See the man page and the Snit FAQ list for more information. * The "info" type and instance methods now take "string match" patterns as appropriate. Changes in V0.9 -------------------------------------------------------------------- For specific changes, please see the file ChangeLog in this directory. Here are the highlights: * Snit widgets and widget adaptors now support the Tk option database. * It's possible set the hull type of a Snit widget to be either a frame or a toplevel. * It's possible to explicitly set the widget class of a Snit widget. * It's possible to explicitly set the resource and class names for all locally defined and explicitly delegated options. * Option and method names can be excluded from "delegate option *" by using the "except" clause, e.g., delegate option * to hull except {-borderwidth -background} * Any Snit type or widget can define a "type constructor": a body of code that's executed when the type is defined. The type constructor is typically used to initialize array-valued type variables, and to add values to the Tk option database. * Components should generally be created and installed using the new "install" command. * snit::widgetadaptor hulls should generally be created and installed using the new "installhull using" form of the "installhull" command. See the Snit man page and FAQ list for more information on these new features. Changes in V0.81 -------------------------------------------------------------------- * All documentation errors people e-mailed to me have been fixed. * Bug fix: weird type names. In Snit 0.8, type names like "hyphenated-name" didn't work because the type name is used as a namespace name, and Tcl won't parse "-" as part of a namespace name unless you quote it somehow. Kudos to Michael Cleverly who both noticed the problem and contributed the patch. * Bug fix: Tcl 8.4.2 incompatibility. There was a bug in Tcl 8.4.1 (and in earlier versions, likely) that if the Tcl command "catch" evaluated a block that contained an explicit "return", "catch" returned 0. The documentation evidently indicated that it should return 2, and so this was fixed in Tcl 8.4.2. This broke a bit of code in Snit. Changes in V0.8 -------------------------------------------------------------------- * Note that there are many incompatibilities between Snit V0.8 and earlier versions; they are all included in this list. * Bug fix: In Snit 0.71 and Snit 0.72, if two instances of a snit::type are created with the same name, the first instance's private data is not destroyed. Hence, [$type info instances] will report that the first instance still exists. This is now fixed. * Snit now requires Tcl 8.4, as it depends on the new command tracing facility. * The snit::widgettype command, which was previously deprecated, has now been deleted. * The snit::widget command has been renamed snit::widgetadaptor; its usage is unchanged, except that the idiom "component hull is ..." is no longer used to define the hull component. Instead, use the "installhull" command: constructor {args} { installhull [label $win ...] $self configurelist $args } * The "component" command is now obsolete, and has been removed. Instead, the "delegate" command implicitly defines an instance variable for the named component; the constructor should assign an object name to that instance variable. For example, whereas you used to write this: snit::type dog { delegate method wag to tail constructor {args} { component tail is [tail $self.tail -partof self] } method gettail {} { return [component tail] } } you now write this: snit::type dog { delegate method wag to tail constructor {args} { set tail [tail $self.tail -partof self] } method gettail {} { return $tail } } * There is a new snit::widget command; unlike snit::widgetadaptor, snit::widget automatically creates a Tk frame widget as the hull widget; the constructor doesn't need to create and set a hull component. * Snit objects may now be renamed without breaking; many of the specific changes which follow are related to this. However, there are some new practices for type authors to follow if they wish to write renameable types and widgets. In particular, * In an instance method, $self will always contain the object's current name, so instance methods can go on calling other instance methods using $self. * If the object is renamed, then $self's value will change. Therefore, don't use $self for anything that will break if $self changes. For example, don't pass a callback as "[list $self methodname]". * If the object passes "[list $self methodname arg1 arg2]" as a callback, the callback will fail when the object is renamed. Instead, the object should pass "[mymethod methodname arg1 arg2]". The [mymethod] command returns the desired command as a list beginning with a name for the object that never changes. For example, in Snit V0.71 you might have used this code to call a method when a Tk button is pushed: .btn configure -command [list $self buttonpress] This still works in V0.8--but the callback will break if your instance is renamed. Here's the safe way to do it: .btn configure -command [mymethod buttonpress] * Every object has a private namespace; the name of this namespace is now available in method bodies, etc., as "$selfns". This value is constant for the life the object. Use "$selfns" instead of "$self" if you need a unique token to identify the object. * When a snit::widget's instance command is renamed, its Tk window name remains the same--and is still extremely important. Consequently, the Tk window name is now available in snit::widget method bodies, etc., as "$win". This value is constant for the life of the object. When creating child windows, it's best to use "$win.child" rather than "$self.child" as the name of the child window. * The names "selfns" and "win" may no longer be used as explicit argument names for typemethods, methods, constructors, or onconfigure handlers. * procs defined in a Snit type or widget definition used to be able to reference instance variables if "$self" was passed to them explicitly as the argument "self"; this is no longer the case. * procs defined in a Snit type or widget definition can now reference instance variables if "$selfns" is passed to them explicitly as the argument "selfns". However, this usage is deprecated. * All Snit type and widget instances can be destroyed by renaming the instance command to "". Changes in V0.72 -------------------------------------------------------------------- * Updated the pkgIndex.tcl file to references snit 0.72 instead of snit 0.7. * Fixed a bug in widget destruction that caused errors like "can't rename "::hull1.f": command doesn't exist". Changes in V0.71 -------------------------------------------------------------------- * KNOWN BUG: The V0.7 documentation implies that a snit::widget can serve as the hull of another snit::widget. Unfortunately, it doesn't work. The fix for this turns out to be extremely complicated, so I plan to fix it in Snit V0.8. Note that a snit::widget can still be composed of other snit::widgets; it's only a problem when the hull component in particular is a snit::widget. * KNOWN BUG: If you rename a Snit type or instance command (i.e., using Tcl's [rename] command) it will no longer work properly. This is part of the reason for the previous bug, and should also be fixed in Snit V0.8. * Enhancement: Snit now preserves the call stack (i.e., the "errorInfo") when rethrowing errors thrown by Snit methods, typemethods, and so forth. This should make debugging Snit types and widgets much easier. In Snit V0.8, I hope to clean up the call stack so that Snit internals are hidden. * Bug fix: Option default values were being processed incorrectly. In particular, if the default value contained brackets, it was treated as a command interpolation. For example, option -regexp {[a-z]+} yield the error that "a-z" isn't a known command. Credit to Keith Waclena for finding this one. * Bug fix: the [$type info instances] command failed to find instances that weren't defined in the global namespace, and found some things that weren't instances. Credit to Keith Waclena for finding this one as well. * Internal Change: the naming convention for instance namespaces within the type namespace has changed. But then, your code shouldn't have depended on that anyway. * Bug fix: snit::widget destruction was seriously broken if the hull component was itself a megawidget (e.g., a BWidget). Each layer of megawidget code needs its opportunity to clean up properly, and that wasn't happening. In addition, the snit::widget destruction code was bound as follows: bind $widgetName {....} which means that if the user of a Snit widget needs to bind to on the widget name they've just wiped out Snit's destructor. Consequently, Snit now creates a bindtag called Snit e.g., Snit::rotext and binds its destroy handler to that. This bindtag is inserted in the snit::widget's bindtags immediately after the widget name. Destruction is always going to be somewhat tricky when multiple levels of megawidgets are involved, as you need to make sure that the destructors are called in inverse order of creation. Changes in V0.7 ---------------------------------------------------------------------- * INCOMPATIBILITY: Snit constructor definitions can now have arbitrary argument lists, as methods do. That is, the type's create method expects the instance name followed by exactly the arguments defined in the constructor's argument list: snit::type dog { variable data constructor {breed color} { set data(breed) $breed set data(color) $color } } dog spot labrador chocolate To get the V0.6 behavior, use the argument "args". That is, the default constructor would be defined in this way: snit::type dog { constructor {args} { $self configurelist $args } } * Added a "$type destroy" type method. It destroys all instances of the type properly (if possible) then deletes the type's namespace and type command. Changes in V0.6 ----------------------------------------------------------------- * Minor corrections to the man page. * The command snit::widgettype is deprecated, in favor of snit::widget. * The variable "type" is now automatically defined in all methods, constructors, destructors, typemethods, onconfigure handlers, and oncget handlers. Thus, a method can call type methods as "$type methodname". * The new standard instance method "info" is used for introspection on type and widget instances: $object info type Returns the object's type. $object info vars Returns a list of the object's instance variables (excluding Snit internal variables). The names are fully qualified. $object info typevars Returns a list of the object's type's type variables (excluding Snit internal variables). The names are fully qualified. $object info options Returns a list of the object's option names. This always includes local options and explicitly delegated options. If unknown options are delegated as well, and if the component to which they are delegated responds to "$object configure" like Tk widgets do, then the result will include all possible unknown options which could be delegated to the component. Note that the return value might be different for different instances of the same type, if component object types can vary from one instance to another. * The new standard typemethod "info" is used for introspection on types: $type info typevars Returns a list of the type's type variables (excluding Snit internal variables). $type info instances Returns a list of the instances of the type. For non-widget types, each instance will be the fully-qualified instance command name; for widget types, each instance will be a widget name. * Bug fixed: great confusion resulted if the hull component of a snit::widgettype was another snit::widgettype. Snit takes over the hull widget's Tk widget command by renaming it to a known name, and putting its own command in its place. The code made no allowance for the fact that this might happen more than once; the second time, the original Tk widget command would be lost. Snit now ensures that the renamed widget command is given a unique name. * Previously, instance methods could call typemethods by name, as though they were normal procs. The downside to this was that if a typemethod name was the same as a standard Tcl command, the typemethod shadowed the standard command in all of the object's code. This is extremely annoying should you wish to define a typemethod called "set". Instance methods must now call typemethods using the type's command, as in "$type methodname". * Typevariable declarations are no longer required in typemethods, methods, or procs provided that the typevariables are defined in the main type or widget definition. * Instance variable declarations are no longer required in methods provided that the instance variables are defined in the main type or widget declaration. * Instance variable declarations are no longer required in procs, provided that the instance variables are defined in the main type or widget declaration. Any proc that includes "self" in its argument list will pick up all such instance variables automatically. * The "configure" method now returns output consistent with Tk's when called with 0 or 1 arguments, i.e., it returns information about one or all options. For options defined by Snit objects, the "dbname" and "classname" returned in the output will be {}. "configure" does its best to do the right thing in the face of delegation. * If the string "%AUTO%" appears in the "name" argument to "$type create" or "$widgettype create", it will be replaced with a string that looks like "$type$n", where "$type" is the type name and "$n" is a counter that's incremented each time a widget of this type is created. This allows the caller to create effectively anonymous instances: widget mylabel {...} set w [mylabel .pane.toolbar.%AUTO% ...] $w configure -text "Some text" * The "create" typemethod is now optional for ordinary types so long as the desired instance name is different than any typemethod name for that type. Thus, the following code creates two dogs, ::spot and ::fido. type dog {...} dog create spot dog fido If there's a conflict between the instance name and a typemethod, either use "create" explicitly, or fully qualify the instance name: dog info -color black ;# Error; assumes "info" typemethod. dog create info -color black ;# OK dog ::info -color black ;# also OK * Bug fix: If any Snit method, typemethod, constructor, or onconfigure handler defines an explicit argument called "type" or "self", the type definition now throws an error, preventing confusing runtime behavior. * Bug fix: If a Snit type or widget definition attempts to define a method or option locally and also delegate it to a component, the type definition now throws an error, preventing confusing runtime behavior. * Bug(?) Fix: Previously, the "$self" command couldn't be used in snit::widget constructors until after the hull component was defined. It is now possible to use the "$self" command to call instance methods at any point in the snit::widget's constructor--always bearing in mind that it's an error to configure delegated options or are call delegated methods before creating the component to which they are delegated. Changes in V0.5 ------------------------------------------------------------------ * Updated the test suite so that Tk-related tests are only run if Tk is available. Credit Jose Nazario for pointing out the problem. * For snit::widgettypes, the "create" keyword is now optional when creating a new instance. That is, either of the following will work: ::snit::widgettype mylabel { } mylabel create .lab1 -text "Using create typemethod" mylabel .lab2 -text "Implied create typemethod" This means that snit::widgettypes can be used identically to normal Tk widgets. Credit goes to Colin McCormack for suggesting this. * Destruction code is now defined using the "destructor" keyword instead of by defining a "destroy" method. If you've been defining the "destroy" method, you need to replace it with "destructor" immediately. See the man page for the syntax. * widgettype destruction is now handled properly (it was buggy). Use the Tk command "destroy" to destroy instances of a widgettype; the "destroy" method isn't automatically defined for widgettypes as it is for normal types, and has no special significance even if it is defined. * Added the "from" command to aid in parsing out specific option values in constructors. Changes in V0.4 ------------------------------------------------------------------ * Added the "codename" command, to qualify type method and private proc names. * Changed the internal implementation of Snit types and widget types to prevent an obscure kind of error and to make it easier to pass private procs as callback commands to other objects. Credit to Rolf Ade for discovering the hole. Changes in V0.3 ------------------------------------------------------------------ * First public release. tcltk2/inst/tklibs/snit2.3.4/roadmap2.txt0000644000176200001440000001401215017041713017527 0ustar liggesusersThis is a roadmap to the code layout in snit.tcl. Package Definition * package provide * ::snit:: namespace definition; exports Snit commands. Major Variable Definitions (this includes a whole lot of code) * ::snit:: variable definitions: * reservedArgs * prettyStackTrace Not used currently * ::snit::typeTemplate Template code shared by all Snit types. As the type definition is parsed, it produced text that gets inserted into this template; then the template is evaluated as though it were sourced from a normal .tcl file. * Type namespace definition * User's typevariable definitions * Commands for use in type code * alias installhull * alias install * alias typevariable * alias variable * alias mytypevar * alias typevarname Deprecated * alias myvar * alias varname Deprecated * alias myproc * alias codename Deprecated * alias mymethod * alias mytypemethod * alias from * Snit's internal variables * See dictionary.txt * Template Code -- Stuff that gets filled in. * proc Snit_instanceVars Initializes instance variables * proc Snit_typeconstructor * Default Procs -- Stuff that's sometimes replaced. * proc Snit_constructor The default constructor * proc Snit_destructor The default destructor (empty) * %COMPILEDDEFS% * Call the Type Constructor * ::snit::nominalTypeProc Template for the normal type proc. * ::snit::simpleTypeProc Template for the simple type proc. This is used when "-hastypemethods no"; all it does is create instances. * ::snit::nominalInstanceProc Template for the body of the normal instance proc. Supports method caching, delegation, etc. * ::snit::simpleInstanceProc Template for the body of the simple instance proc, used when "-simpledispatch yes". Doesn't support delegation, upvar, hierarchical methods, or exotic return types. * Snit compilation variables * compiler The name of the slave interpreter used to "compile" type definitions * compile Array, accumulates results of "compiling" type definitions * reservedwords List of names that can't be used as macros. Basically, any command defined before the first macro. Compilation Commands * proc ::snit::Comp.Init * proc ::snit::Comp.Compile * proc ::snit::Comp.SaveOptionInfo * proc ::snit::Comp.Define * proc ::snit::Comp.statement.pragma * proc ::snit::Comp.statement.widgetclass * proc ::snit::Comp.statement.hulltype * proc ::snit::Comp.statement.constructor * proc ::snit::Comp.statement.destructor * proc ::snit::Comp.statement.option * proc ::snit::Comp.OptionNameIsValid * proc ::snit::Comp.statement.oncget * proc ::snit::Comp.statement.onconfigure * proc ::snit::Comp.statement.method * proc ::snit::Comp.CheckMethodName * proc ::snit::Comp.statement.typemethod * proc ::snit::Comp.statement.typeconstructor * proc ::snit::Comp.statement.proc * proc ::snit::Comp.statement.typevariable * proc ::snit::Comp.statement.variable * proc ::snit::Comp.statement.typecomponent * proc ::snit::Comp.DefineTypeComponent * proc ::snit::Comp.statement.component * proc ::snit::Comp.DefineComponent * proc ::snit::Comp.statement.delegate * proc ::snit::Comp.DelegatedTypemethod * proc ::snit::Comp.DelegatedMethod * proc ::snit::Comp.DelegatedOption * proc ::snit::Comp.statement.expose Public Commands * proc ::snit::compile * proc ::snit::type * proc ::snit::widgetadaptor * proc ::snit::widget * proc ::snit::typemethod * proc ::snit::method * proc ::snit::macro Utility Commands * proc ::snit::Expand * proc ::snit::Mappend * proc ::snit::CheckArgs * proc ::snit::Capitalize Snit Runtime Library The commands defined here are used by Snit-generated code at run-time rather than compile time. * Object Creation ** ::snit::RT.type.typemethod.create ** ::snit::RT.widget.typemethod.create ** ::snit::RT.MakeInstanceCommand ** ::snit::RT.InstanceTrace ** ::snit::RT.ConstructInstance ** ::snit::RT.UniqueName ** ::snit::RT.UniqueInstanceNamespace ** ::snit::RT.OptionDbGet * Object Destruction ** ::snit::RT.method.destroy ** ::snit::RT.DestroyObject ** ::snit::RT.RemoveInstanceTrace * Typecomponent Management and Typemethod Caching ** ::snit::RT.TypecomponentTrace ** ::snit::RT.UnknownTypemethod * Component Management and Method Caching ** ::snit::RT.Component ** ::snit::RT.ComponentTrace ** ::snit::RT.UnknownMethod ** ::snit::RT.ClearInstanceCaches * Component Installation ** ::snit::RT.installhull ** ::snit::RT.install * Method/Variable Name Qualification ** ::snit::RT.variable ** ::snit::RT.mytypevar ** ::snit::RT.myvar ** ::snit::RT.myproc ** ::snit::RT.codename ** ::snit::RT.mytypemethod ** ::snit::RT.mymethod ** ::snit::RT.CallInstance * Utilities ** ::snit::RT.from * Type Destruction ** ::snit::RT.typemethod.destroy * Option Handling ** ::snit::RT.method.cget ** ::snit::RT.CacheCgetCommand ** ::snit::RT.method.configurelist ** ::snit::RT.CacheConfigureCommand ** ::snit::RT.method.configure ** ::snit::RT.GetOptionDbSpec * Type Introspection ** ::snit::RT.typemethod.info ** ::snit::RT.typemethod.info.typevars ** ::snit::RT.typemethod.info.typemethods ** ::snit::RT.typemethod.info.instances * Instance Introspection ** ::snit::RT.method.info ** ::snit::RT.method.info.type ** ::snit::RT.method.info.typevars ** ::snit::RT.method.info.typemethods ** ::snit::RT.method.info.methods ** ::snit::RT.method.info.vars ** ::snit::RT.method.info.options tcltk2/inst/tklibs/snit2.3.4/snit.man0000644000176200001440000026203315017041713016743 0ustar liggesusers[comment {-*- tcl -*- doctools manpage}] [vset VERSION 2.3.4] [manpage_begin snit n [vset VERSION]] [keywords adaptors] [keywords BWidget] [keywords C++] [keywords class] [keywords {Incr Tcl}] [keywords {mega widget}] [keywords object] [keywords {object oriented}] [keywords Snit] [keywords type] [keywords widget] [keywords {widget adaptors}] [copyright {2003-2009, by William H. Duquette}] [moddesc {Snit's Not Incr Tcl, OO system}] [titledesc {Snit's Not Incr Tcl}] [category {Programming tools}] [require Tcl "8.5 9"] [require snit [opt [vset VERSION]]] [description] [para] Snit is a pure Tcl object and megawidget system. It's unique among Tcl object systems in that it's based not on inheritance but on delegation. Object systems based on inheritance only allow you to inherit from classes defined using the same system, which is limiting. In Tcl, an object is anything that acts like an object; it shouldn't matter how the object was implemented. Snit is intended to help you build applications out of the materials at hand; thus, Snit is designed to be able to incorporate and build on any object, whether it's a hand-coded object, a [package Tk] widget, an [package {Incr Tcl}] object, a [package BWidget] or almost anything else. [para] This man page is intended to be a reference only; see the accompanying [cmd snitfaq] for a gentler, more tutorial introduction to Snit concepts. [section {SNIT VERSIONS}] This man page covers both Snit 2.2 and Snit 1.3. The primary difference between the two versions is simply that Snit 2.2 contains speed optimizations based on new features of Tcl 8.5; Snit 1.3 supports all of Tcl 8.3, 8.4 and Tcl 8.5. There are a few minor inconsistencies; they are flagged in the body of the man page with the label "Snit 1.x Incompatibility"; they are also discussed in the [cmd snitfaq]. [para] [section REFERENCE] [subsection {Type and Widget Definitions}] Snit provides the following commands for defining new types: [list_begin definitions] [call [cmd snit::type] [arg name] [arg definition]] Defines a new abstract data type called [arg name]. If [arg name] is not a fully qualified command name, it is assumed to be a name in the namespace in which the [cmd snit::type] command was called (usually the global namespace). It returns the fully qualified name of the new type. [para] The type name is then a command that is used to create objects of the new type, along with other activities. [para] The [cmd snit::type] [arg definition] block is a script that may contain the following definitions: [list_begin definitions] [call [cmd typevariable] [arg name] [opt [const -array]] [opt [arg value]]] Defines a type variable with the specified [arg name], and optionally the specified [arg value]. Type variables are shared by all instances of the type. If the [const -array] option is included, then [arg value] should be a dictionary; it will be assigned to the variable using [cmd "array set"]. [call [cmd typemethod] [arg name] [arg arglist] [arg body]] Defines a type method, a subcommand of the new type command, with the specified name, argument list, and body. The [arg arglist] is a normal Tcl argument list and may contain default arguments and the [var args] argument; however, it may not contain the argument names [var type], [var self], [var selfns], or [var win]. [para] The variable [var type] is automatically defined in the [arg body] to the type's fully-qualified name. In addition, type variables are automatically visible in the [arg body] of every type method. [para] If the [arg name] consists of two or more tokens, Snit handles it specially: [example { typemethod {a b} {arg} { puts "Got $arg" } }] This statement implicitly defines a type method called [const a] which has a subcommand [const b]. [const b] is called like this: [example { $type a b "Hello, world!" }] [const a] may have any number of subcommands. This makes it possible to define a hierarchical command structure; see [cmd method], below, for more examples. [para] Type methods can call commands from the namespace in which the type is defined without importing them, e.g., if the type name is [cmd ::parentns::typename], then the type's type methods can call [cmd ::parentns::someproc] just as [cmd someproc]. [emph {Snit 1.x Incompatibility:}] This does not work in Snit 1.x, as it depends on [cmd "namespace path"], a new command in Tcl 8.5. [para] [emph {Snit 1.x Incompatibility:}] In Snit 1.x, the following following two calls to this type method are equivalent: [example { $type a b "Hello, world!" $type {a b} "Hello, world!" }] In Snit 2.2, the second form is invalid. [call [cmd typeconstructor] [arg body]] The type constructor's [arg body] is executed once when the type is first defined; it is typically used to initialize array-valued type variables and to add entries to [sectref {The Tk Option Database}]. [para] The variable [var type] is automatically defined in the [arg body], and contains the type's fully-qualified name. In addition, type variables are automatically visible in the [arg body] of the type constructor. [para] A type may define at most one type constructor. [para] The type constructor can call commands from the namespace in which the type is defined without importing them, e.g., if the type name is [cmd ::parentns::typename], then the type constructor can call [cmd ::parentns::someproc] just as [cmd someproc]. [emph {Snit 1.x Incompatibility:}] This does not work in Snit 1.x, as it depends on [cmd "namespace path"], a new command in Tcl 8.5. [call [cmd variable] [arg name] [opt [const -array]] [opt [arg value]]] Defines an instance variable, a private variable associated with each instance of this type, and optionally its initial value. If the [const -array] option is included, then [arg value] should be a dictionary; it will be assigned to the variable using [cmd "array set"]. [call [cmd method] [arg name] [arg arglist] [arg body]] Defines an instance method, a subcommand of each instance of this type, with the specified name, argument list and body. The [arg arglist] is a normal Tcl argument list and may contain default arguments and the [var args] argument. [para] The method is implicitly passed the following arguments as well: [var type], which contains the fully-qualified type name; [var self], which contains the current instance command name; [var selfns], which contains the name of the instance's private namespace; and [var win], which contains the original instance name. Consequently, the [arg arglist] may not contain the argument names [const type], [const self], [const selfns], or [const win]. [para] An instance method defined in this way is said to be [term {locally defined}]. [para] Type and instance variables are automatically visible in all instance methods. If the type has locally defined options, the [var options] array is also visible. [para] If the [arg name] consists of two or more tokens, Snit handles it specially: [example { method {a b} {} { ... } }] This statement implicitly defines a method called [const a] which has a subcommand [const b]. [const b] is called like this: [example { $self a b "Hello, world!" }] [const a] may have any number of subcommands. This makes it possible to define a hierarchical command structure: [example {% snit::type dog { method {tail wag} {} {return "Wag, wag"} method {tail droop} {} {return "Droop, droop"} } ::dog % dog spot ::spot % spot tail wag Wag, wag % spot tail droop Droop, droop % }] What we've done is implicitly defined a "tail" method with subcommands "wag" and "droop". Consequently, it's an error to define "tail" explicitly. [para] Methods can call commands from the namespace in which the type is defined without importing them, e.g., if the type name is [cmd ::parentns::typename], then the type's methods can call [cmd ::parentns::someproc] just as [cmd someproc]. [emph {Snit 1.x Incompatibility:}] This does not work in Snit 1.x, as it depends on [cmd "namespace path"], a new command in Tcl 8.5. [para] [emph {Snit 1.x Incompatibility:}] In Snit 1.x, the following following two calls to this method are equivalent: [example { $self a b "Hello, world!" $self {a b} "Hello, world!" }] In Snit 2.2, the second form is invalid. [call [cmd option] [arg namespec] [opt [arg defaultValue]]] [call [cmd option] [arg namespec] [opt [arg options...]]] Defines an option for instances of this type, and optionally gives it an initial value. The initial value defaults to the empty string if no [arg defaultValue] is specified. [para] An option defined in this way is said to be [term {locally defined}]. [para] The [arg namespec] is a list defining the option's name, resource name, and class name, e.g.: [example { option {-font font Font} {Courier 12} }] The option name must begin with a hyphen, and must not contain any upper case letters. The resource name and class name are optional; if not specified, the resource name defaults to the option name, minus the hyphen, and the class name defaults to the resource name with the first letter capitalized. Thus, the following statement is equivalent to the previous example: [example { option -font {Courier 12} }] See [sectref {The Tk Option Database}] for more information about resource and class names. [para] Options are normally set and retrieved using the standard instance methods [method configure] and [method cget]; within instance code (method bodies, etc.), option values are available through the [var options] array: [example { set myfont $options(-font) }] If the type defines any option handlers (e.g., [const -configuremethod]), then it should probably use [method configure] and [method cget] to access its options to avoid subtle errors. [para] The [cmd option] statement may include the following options: [list_begin definitions] [def "[const -default] [arg defvalue]"] Defines the option's default value; the option's default value will be "" otherwise. [def "[const -readonly] [arg flag]"] The [arg flag] can be any Boolean value recognized by Tcl. If [arg flag] is true, then the option is read-only--it can only be set using [method configure] or [method configurelist] at creation time, i.e., in the type's constructor. [def "[const -type] [arg type]"] Every locally-defined option may define its validation type, which may be either the name of a validation type or a specification for a validation subtype [para] For example, an option may declare that its value must be an integer by specifying [cmd snit::integer] as its validation type: [example { option -number -type snit::integer }] It may also declare that its value is an integer between 1 and 10 by specifying a validation subtype: [example { option -number -type {snit::integer -min 1 -max 10} }] If a validation type or subtype is defined for an option, then it will be used to validate the option's value whenever it is changed by the object's [method configure] or [method configurelist] methods. In addition, all such options will have their values validated automatically immediately after the constructor executes. [para] Snit defines a family of validation types and subtypes, and it's quite simple to define new ones. See [sectref "Validation Types"] for the complete list, and [sectref "Defining Validation Types"] for an explanation of how to define your own. [def "[const -cgetmethod] [arg methodName]"] Every locally-defined option may define a [const -cgetmethod]; it is called when the option's value is retrieved using the [method cget] method. Whatever the method's [arg body] returns will be the return value of the call to [method cget]. [para] The named method must take one argument, the option name. For example, this code is equivalent to (though slower than) Snit's default handling of [cmd cget]: [example { option -font -cgetmethod GetOption method GetOption {option} { return $options($option) } }] Note that it's possible for any number of options to share a [const -cgetmethod]. [def "[const -configuremethod] [arg methodName]"] Every locally-defined option may define a [const -configuremethod]; it is called when the option's value is set using the [method configure] or [method configurelist] methods. It is the named method's responsibility to save the option's value; in other words, the value will not be saved to the [var options()] array unless the method saves it there. [para] The named method must take two arguments, the option name and its new value. For example, this code is equivalent to (though slower than) Snit's default handling of [cmd configure]: [example { option -font -configuremethod SetOption method SetOption {option value} { set options($option) $value } }] Note that it's possible for any number of options to share a single [const -configuremethod]. [def "[const -validatemethod] [arg methodName]"] Every locally-defined option may define a [const -validatemethod]; it is called when the option's value is set using the [method configure] or [method configurelist] methods, just before the [const -configuremethod] (if any). It is the named method's responsibility to validate the option's new value, and to throw an error if the value is invalid. [para] The named method must take two arguments, the option name and its new value. For example, this code verifies that [const -flag]'s value is a valid Boolean value: [example { option -font -validatemethod CheckBoolean method CheckBoolean {option value} { if {![string is boolean -strict $value]} { error "option $option must have a boolean value." } } }] Note that it's possible for any number of options to share a single [const -validatemethod]. [list_end] [call [cmd constructor] [arg arglist] [arg body]] The constructor definition specifies a [arg body] of code to be executed when a new instance is created. The [arg arglist] is a normal Tcl argument list and may contain default arguments and the [var args] argument. [para] As with methods, the arguments [var type], [var self], [var selfns], and [var win] are defined implicitly, and all type and instance variables are automatically visible in its [arg body]. [para] If the [arg definition] doesn't explicitly define the constructor, Snit defines one implicitly. If the type declares at least one option (whether locally or by delegation), the default constructor will be defined as follows: [example { constructor {args} { $self configurelist $args } }] For standard Tk widget behavior, the argument list should be the single name [const args], as shown. [para] If the [arg definition] defines neither a constructor nor any options, the default constructor is defined as follows: [example { constructor {} {} }] As with methods, the constructor can call commands from the namespace in which the type is defined without importing them, e.g., if the type name is [cmd ::parentns::typename], then the constructor can call [cmd ::parentns::someproc] just as [cmd someproc]. [emph {Snit 1.x Incompatibility:}] This does not work in Snit 1.x, as it depends on [cmd "namespace path"], a new command in Tcl 8.5. [call [cmd destructor] [arg body]] The destructor is used to code any actions that must take place when an instance of the type is destroyed: typically, the destruction of anything created in the constructor. [para] The destructor takes no explicit arguments; as with methods, the arguments [var type], [var self], [var selfns], and [var win], are defined implicitly, and all type and instance variables are automatically visible in its [arg body]. As with methods, the destructor can call commands from the namespace in which the type is defined without importing them, e.g., if the type name is [cmd ::parentns::typename], then the destructor can call [cmd ::parentns::someproc] just as [cmd someproc]. [emph {Snit 1.x Incompatibility:}] This does not work in Snit 1.x, as it depends on [cmd "namespace path"], a new command in Tcl 8.5. [call [cmd proc] [arg name] [arg args] [arg body]] Defines a new Tcl procedure in the type's namespace. [para] The defined proc differs from a normal Tcl proc in that all type variables are automatically visible. The proc can access instance variables as well, provided that it is passed [var selfns] (with precisely that name) as one of its arguments. [para] Although they are not implicitly defined for procs, the argument names [const type], [const self], and [const win] should be avoided. [para] As with methods and typemethods, procs can call commands from the namespace in which the type is defined without importing them, e.g., if the type name is [cmd ::parentns::typename], then the proc can call [cmd ::parentns::someproc] just as [cmd someproc]. [emph {Snit 1.x Incompatibility:}] This does not work in Snit 1.x, as it depends on [cmd "namespace path"], a new command in Tcl 8.5. [call [cmd delegate] [const method] [arg name] [const to] [arg comp] [opt "[const as] [arg target]"]] Delegates method [arg name] to component [arg comp]. That is, when method [arg name] is called on an instance of this type, the method and its arguments will be passed to the named component's command instead. That is, the following statement [example { delegate method wag to tail }] is roughly equivalent to this explicitly defined method: [example { method wag {args} { uplevel $tail wag $args } }] As with methods, the [arg name] may have multiple tokens; in this case, the last token of the name is assumed to be the name of the component's method. [para] The optional [const as] clause allows you to specify the delegated method name and possibly add some arguments: [example { delegate method wagtail to tail as "wag briskly" }] [para] A method cannot be both locally defined and delegated. [para] [const Note:] All forms of [cmd "delegate method"] can delegate to both instance components and type components. [call [cmd delegate] [const method] [arg name] [opt "[const to] [arg comp]"] [const using] [arg pattern]] In this form of the [cmd delegate] statement, the [const using] clause is used to specify the precise form of the command to which method [arg name] name is delegated. In this form, the [const "to"] clause is optional, since the chosen command might not involve any particular component. [para] The value of the [const using] clause is a list that may contain any or all of the following substitution codes; these codes are substituted with the described value to build the delegated command prefix. Note that the following two statements are equivalent: [example { delegate method wag to tail delegate method wag to tail using "%c %m" }] Each element of the list becomes a single element of the delegated command--it is never reparsed as a string. [para] Substitutions: [list_begin definitions] [def [const %%]] This is replaced with a single "%". Thus, to pass the string "%c" to the command as an argument, you'd write "%%c". [def [const %c]] This is replaced with the named component's command. [def [const %m]] This is replaced with the final token of the method [arg name]; if the method [arg name] has one token, this is identical to [const %M]. [def [const %M]] This is replaced by the method [arg name]; if the [arg name] consists of multiple tokens, they are joined by space characters. [def [const %j]] This is replaced by the method [arg name]; if the [arg name] consists of multiple tokens, they are joined by underscores ("_"). [def [const %t]] This is replaced with the fully qualified type name. [def [const %n]] This is replaced with the name of the instance's private namespace. [def [const %s]] This is replaced with the name of the instance command. [def [const %w]] This is replaced with the original name of the instance command; for Snit widgets and widget adaptors, it will be the Tk window name. It remains constant, even if the instance command is renamed. [list_end] [call [cmd delegate] [const method] [const *] [opt "[const to] [arg comp]"] [opt "[const using] [arg pattern]"] [opt "[const except] [arg exceptions]"]] The form [cmd "delegate method *"] delegates all unknown method names to the specified [arg comp]onent. The [const except] clause can be used to specify a list of [arg exceptions], i.e., method names that will not be so delegated. The [const using] clause is defined as given above. In this form, the statement must contain the [const to] clause, the [const using] clause, or both. [para] In fact, the "*" can be a list of two or more tokens whose last element is "*", as in the following example: [example { delegate method {tail *} to tail }] This implicitly defines the method [cmd tail] whose subcommands will be delegated to the [var tail] component. [call [cmd delegate] [const option] [arg namespec] [const to] [arg comp]] [call [cmd delegate] [const option] [arg namespec] [const to] [arg comp] [const as] [arg target]] [call [cmd delegate] [const option] [const *] [const to] [arg comp]] [call [cmd delegate] [const option] [const *] [const to] [arg comp] [const except] [arg exceptions]] Defines a delegated option; the [arg namespec] is defined as for the [cmd option] statement. When the [method configure], [method configurelist], or [method cget] instance method is used to set or retrieve the option's value, the equivalent [method configure] or [method cget] command will be applied to the component as though the option was defined with the following [const -configuremethod] and [const -cgetmethod]: [example { method ConfigureMethod {option value} { $comp configure $option $value } method CgetMethod {option} { return [$comp cget $option] } }] Note that delegated options never appear in the [var options] array. [para] If the [const as] clause is specified, then the [arg target] option name is used in place of [arg name]. [para] The form [cmd "delegate option *"] delegates all unknown options to the specified [arg comp]onent. The [const except] clause can be used to specify a list of [arg exceptions], i.e., option names that will not be so delegated. [para] Warning: options can only be delegated to a component if it supports the [method configure] and [method cget] instance methods. [para] An option cannot be both locally defined and delegated. TBD: Continue from here. [call [cmd component] [arg comp] \ [opt "[const -public] [arg method]"] \ [opt "[const -inherit] [arg flag]"]] Explicitly declares a component called [arg comp], and automatically defines the component's instance variable. [para] If the [const -public] option is specified, then the option is made public by defining a [arg method] whose subcommands are delegated to the component e.g., specifying [const "-public mycomp"] is equivalent to the following: [example { component mycomp delegate method {mymethod *} to mycomp }] If the [const -inherit] option is specified, then [arg flag] must be a Boolean value; if [arg flag] is true then all unknown methods and options will be delegated to this component. The name [const -inherit] implies that instances of this new type inherit, in a sense, the methods and options of the component. That is, [const "-inherit yes"] is equivalent to: [example { component mycomp delegate option * to mycomp delegate method * to mycomp }] [call [cmd delegate] [const typemethod] [arg name] [const to] [arg comp] [opt "[const as] [arg target]"]] Delegates type method [arg name] to type component [arg comp]. That is, when type method [arg name] is called on this type, the type method and its arguments will be passed to the named type component's command instead. That is, the following statement [example { delegate typemethod lostdogs to pound }] is roughly equivalent to this explicitly defined method: [example { typemethod lostdogs {args} { uplevel $pound lostdogs $args } }] As with type methods, the [arg name] may have multiple tokens; in this case, the last token of the name is assumed to be the name of the component's method. [para] The optional [const as] clause allows you to specify the delegated method name and possibly add some arguments: [example { delegate typemethod lostdogs to pound as "get lostdogs" }] [para] A type method cannot be both locally defined and delegated. [call [cmd delegate] [const typemethod] [arg name] [opt "[const to] [arg comp]"] [const using] [arg pattern]] In this form of the [cmd delegate] statement, the [const using] clause is used to specify the precise form of the command to which type method [arg name] name is delegated. In this form, the [const "to"] clause is optional, since the chosen command might not involve any particular type component. [para] The value of the [const using] clause is a list that may contain any or all of the following substitution codes; these codes are substituted with the described value to build the delegated command prefix. Note that the following two statements are equivalent: [example { delegate typemethod lostdogs to pound delegate typemethod lostdogs to pound using "%c %m" }] Each element of the list becomes a single element of the delegated command--it is never reparsed as a string. [para] Substitutions: [list_begin definitions] [def [const %%]] This is replaced with a single "%". Thus, to pass the string "%c" to the command as an argument, you'd write "%%c". [def [const %c]] This is replaced with the named type component's command. [def [const %m]] This is replaced with the final token of the type method [arg name]; if the type method [arg name] has one token, this is identical to [const %M]. [def [const %M]] This is replaced by the type method [arg name]; if the [arg name] consists of multiple tokens, they are joined by space characters. [def [const %j]] This is replaced by the type method [arg name]; if the [arg name] consists of multiple tokens, they are joined by underscores ("_"). [def [const %t]] This is replaced with the fully qualified type name. [list_end] [call [cmd delegate] [const typemethod] [const *] [opt "[const to] [arg comp]"] \ [opt "[const using] [arg pattern]"] [opt "[const except] [arg exceptions]"]] The form [cmd "delegate typemethod *"] delegates all unknown type method names to the specified type component. The [const except] clause can be used to specify a list of [arg exceptions], i.e., type method names that will not be so delegated. The [const using] clause is defined as given above. In this form, the statement must contain the [const to] clause, the [const using] clause, or both. [para] [const Note:] By default, Snit interprets [cmd "\$type foo"], where [const "foo"] is not a defined type method, as equivalent to [cmd "\$type create foo"], where [const "foo"] is the name of a new instance of the type. If you use [const "delegate typemethod *"], then the [method "create"] type method must always be used explicitly. [para] The "*" can be a list of two or more tokens whose last element is "*", as in the following example: [example { delegate typemethod {tail *} to tail }] This implicitly defines the type method [cmd tail] whose subcommands will be delegated to the [var tail] type component. [call [cmd typecomponent] [arg comp] \ [opt "[const -public] [arg typemethod]"] \ [opt "[const -inherit] [arg flag]"]] Explicitly declares a type component called [arg comp], and automatically defines the component's type variable. A type component is an arbitrary command to which type methods and instance methods can be delegated; the command's name is stored in a type variable. [para] If the [const -public] option is specified, then the type component is made public by defining a [arg typemethod] whose subcommands are delegated to the type component, e.g., specifying [const "-public mytypemethod"] is equivalent to the following: [example { typecomponent mycomp delegate typemethod {mytypemethod *} to mycomp }] If the [const -inherit] option is specified, then [arg flag] must be a Boolean value; if [arg flag] is true then all unknown type methods will be delegated to this type component. (See the note on "delegate typemethod *", above.) The name [const -inherit] implies that this type inherits, in a sense, the behavior of the type component. That is, [const "-inherit yes"] is equivalent to: [example { typecomponent mycomp delegate typemethod * to mycomp }] [call [cmd pragma] [opt [arg options...]]] The [cmd pragma] statement provides control over how Snit generates a type. It takes the following options; in each case, [arg flag] must be a Boolean value recognized by Tcl, e.g., [const 0], [const 1], [const "yes"], [const "no"], and so on. [para] By setting the [const -hastypeinfo], [const -hastypedestroy], and [const -hasinstances] pragmas to false and defining appropriate type methods, you can create an ensemble command without any extraneous behavior. [list_begin definitions] [def "[const -canreplace] [arg flag]"] If false (the default) Snit will not create an instance of a [cmd snit::type] that has the same name as an existing command; this prevents subtle errors. Setting this pragma to true restores the behavior of Snit V0.93 and earlier versions. [def "[const -hastypeinfo] [arg flag]"] If true (the default), the generated type will have a type method called [cmd info] that is used for type introspection; the [cmd info] type method is documented below. If false, it will not. [def "[const -hastypedestroy] [arg flag]"] If true (the default), the generated type will have a type method called [cmd destroy] that is used to destroy the type and all of its instances. The [cmd destroy] type method is documented below. If false, it will not. [def "[const -hastypemethods] [arg flag]"] If true (the default), the generated type's type command will have subcommands (type methods) as usual. If false, the type command will serve only to create instances of the type; the first argument is the instance name. [para] This pragma and [const -hasinstances] cannot both be set false. [def "[const -hasinstances] [arg flag]"] If true (the default), the generated type will have a type method called [cmd create] that is used to create instances of the type, along with a variety of instance-related features. If false, it will not. [para] This pragma and [const -hastypemethods] cannot both be set false. [def "[const -hasinfo] [arg flag]"] If true (the default), instances of the generated type will have an instance method called [method info] that is used for instance introspection; the [method info] method is documented below. If false, it will not. [def "[const -simpledispatch] [arg flag]"] This pragma is intended to make simple, heavily-used abstract data types (e.g., stacks and queues) more efficient. [para] If false (the default), instance methods are dispatched normally. If true, a faster dispatching scheme is used instead. The speed comes at a price; with [const "-simpledispatch yes"] you get the following limitations: [list_begin itemized] [item] Methods cannot be delegated. [item] [cmd uplevel] and [cmd upvar] do not work as expected: the caller's scope is two levels up rather than one. [item] The option-handling methods ([cmd cget], [cmd configure], and [cmd configurelist]) are very slightly slower. [list_end] [list_end] [call [cmd expose] [arg comp]] [call [cmd expose] [arg comp] [const as] [arg method]] [comment { The word "Deprecated" really needs to be boldface, and there's no good way to do it, so I'm using "const". }] [const Deprecated.] To expose component [arg comp] publicly, use [cmd component]'s [const -public] option. [call [cmd onconfigure] [arg name] [arg arglist] [arg body]] [const Deprecated.] Define [cmd option]'s [const -configuremethod] option instead. [para] As of version 0.95, the following definitions, [example { option -myoption onconfigure -myoption {value} { # Code to save the option's value } }] are implemented as follows: [example { option -myoption -configuremethod _configure-myoption method _configure-myoption {_option value} { # Code to save the option's value } }] [call [cmd oncget] [arg name] [arg body]] [const Deprecated.] Define [cmd option]'s [const -cgetmethod] option instead. [para] As of version 0.95, the following definitions, [example { option -myoption oncget -myoption { # Code to return the option's value } }] are implemented as follows: [example { option -myoption -cgetmethod _cget-myoption method _cget-myoption {_option} { # Code to return the option's value } }] [list_end] [call [cmd snit::widget] [arg name] [arg definition]] This command defines a Snit megawidget type with the specified [arg name]. The [arg definition] is defined as for [cmd snit::type]. A [cmd snit::widget] differs from a [cmd snit::type] in these ways: [list_begin itemized] [item] Every instance of a [cmd snit::widget] has an automatically-created component called [var hull], which is normally a Tk frame widget. Other widgets created as part of the megawidget will be created within this widget. [para] The hull component is initially created with the requested widget name; then Snit does some magic, renaming the hull component and installing its own instance command in its place. The hull component's new name is saved in an instance variable called [var hull]. [item] The name of an instance must be valid Tk window name, and the parent window must exist. [list_end] A [cmd snit::widget] definition can include any of statements allowed in a [cmd snit::type] definition, and may also include the following: [list_begin definitions] [call [cmd widgetclass] [arg name]] Sets the [cmd snit::widget]'s widget class to [arg name], overriding the default. See [sectref {The Tk Option Database}] for more information. [call [cmd hulltype] [arg type]] Determines the kind of widget used as the [cmd snit::widget]'s hull. The [arg type] may be [const frame] (the default), [const toplevel], [const labelframe]; the qualified equivalents of these, [const tk::frame], [const tk::toplevel], and [const tk::labelframe]; or, if available, the equivalent Tile widgets: [const ttk::frame], [const ttk::toplevel], and [const ttk::labelframe]. In practice, any widget that supports the [const -class] option can be used as a hull widget by [cmd lappend]'ing its name to the variable [var snit::hulltypes]. [list_end] [call [cmd snit::widgetadaptor] [arg name] [arg definition]] This command defines a Snit megawidget type with the specified name. It differs from [cmd snit::widget] in that the instance's [var hull] component is not created automatically, but is created in the constructor and installed using the [cmd installhull] command. Once the hull is installed, its instance command is renamed and replaced as with normal [cmd snit::widget]s. The original command is again accessible in the instance variable [var hull]. [para] Note that in general it is not possible to change the [emph {widget class}] of a [cmd snit::widgetadaptor]'s hull widget. [para] See [sectref {The Tk Option Database}] for information on how [cmd snit::widgetadaptor]s interact with the option database. [call [cmd snit::typemethod] [arg type] [arg name] [arg arglist] [arg body]] Defines a new type method (or redefines an existing type method) for a previously existing [arg type]. [call [cmd snit::method] [arg type] [arg name] [arg arglist] [arg body]] Defines a new instance method (or redefines an existing instance method) for a previously existing [arg type]. Note that delegated instance methods can't be redefined. [call [cmd snit::macro] [arg name] [arg arglist] [arg body]] Defines a Snit macro with the specified [arg name], [arg arglist], and [arg body]. Macros are used to define new type and widget definition statements in terms of the statements defined in this man page. [para] A macro is simply a Tcl proc that is defined in the slave interpreter used to compile type and widget definitions. Thus, macros have access to all of the type and widget definition statements. See [sectref "Macros and Meta-programming"] for more details. [para] The macro [arg name] cannot be the same as any standard Tcl command, or any Snit type or widget definition statement, e.g., you can't redefine the [cmd method] or [cmd delegate] statements, or the standard [cmd set], [cmd list], or [cmd string] commands. [call [cmd snit::compile] [arg which] [arg type] [arg body]] Snit defines a type, widget, or widgetadaptor by "compiling" the definition into a Tcl script; this script is then evaluated in the Tcl interpreter, which actually defines the new type. [para] This command exposes the "compiler". Given a definition [arg body] for the named [arg type], where [arg which] is [const type], [const widget], or [const widgetadaptor], [cmd snit::compile] returns a list of two elements. The first element is the fully qualified type name; the second element is the definition script. [para] [cmd snit::compile] is useful when additional processing must be done on the Snit-generated code--if it must be instrumented, for example, or run through the TclDevKit compiler. In addition, the returned script could be saved in a ".tcl" file and used to define the type as part of an application or library, thus saving the compilation overhead at application start-up. Note that the same version of Snit must be used at run-time as at compile-time. [list_end] [subsection {The Type Command}] A type or widget definition creates a type command, which is used to create instances of the type. The type command has this form: [para] [list_begin definitions] [call [cmd {$type}] [arg typemethod] [arg args]...] The [arg typemethod] can be any of the [sectref "Standard Type Methods"] (e.g., [method create]), or any type method defined in the type definition. The subsequent [arg args] depend on the specific [arg typemethod] chosen. [para] The type command is most often used to create new instances of the type; hence, the [method create] method is assumed if the first argument to the type command doesn't name a valid type method, unless the type definition includes [cmd "delegate typemethod *"] or the [const -hasinstances] pragma is set to false. [para] Furthermore, if the [const -hastypemethods] pragma is false, then Snit type commands can be called with no arguments at all; in this case, the type command creates an instance with an automatically generated name. In other words, provided that the [const -hastypemethods] pragma is false and the type has instances, the following commands are equivalent: [example {snit::type dog { ... } set mydog [dog create %AUTO%] set mydog [dog %AUTO%] set mydog [dog] }] This doesn't work for Snit widgets, for obvious reasons. [para] [emph "Snit 1.x Incompatibility:"] In Snit 1.x, the above behavior is available whether [const -hastypemethods] is true (the default) or false. [list_end] [subsection {Standard Type Methods}] In addition to any type methods in the type's definition, all type and widget commands will usually have at least the following subcommands: [para] [list_begin definitions] [call [cmd {$type}] [method create] [arg name] [opt "[arg option] [arg value] ..."]] Creates a new instance of the type, giving it the specified [arg name] and calling the type's constructor. [para] For [cmd snit::type]s, if [arg name] is not a fully-qualified command name, it is assumed to be a name in the namespace in which the call to [cmd snit::type] appears. The method returns the fully-qualified instance name. [para] For [cmd snit::widget]s and [cmd snit::widgetadaptor]s, [arg name] must be a valid widget name; the method returns the widget name. [para] So long as [arg name] does not conflict with any defined type method name the [method create] keyword may be omitted, unless the type definition includes [cmd "delegate typemethod *"] or the [const -hasinstances] pragma is set to false. [para] If the [arg name] includes the string [const %AUTO%], it will be replaced with the string [const {$type$counter}] where [const {$type}] is the type name and [const {$counter}] is a counter that increments each time [const %AUTO%] is used for this type. [para] By default, any arguments following the [arg name] will be a list of [arg option] names and their [arg value]s; however, a type's constructor can specify a different argument list. [para] As of Snit V0.95, [method create] will throw an error if the [arg name] is the same as any existing command--note that this was always true for [cmd snit::widget]s and [cmd snit::widgetadaptor]s. You can restore the previous behavior using the [const -canreplace] pragma. [call [cmd {$type}] [method {info typevars}] [opt [arg pattern]]] Returns a list of the type's type variables (excluding Snit internal variables); all variable names are fully-qualified. [para] If [arg pattern] is given, it's used as a [cmd {string match}] pattern; only names that match the pattern are returned. [call [cmd {$type}] [method {info typemethods}] [opt [arg pattern]]] Returns a list of the names of the type's type methods. If the type has hierarchical type methods, whether locally-defined or delegated, only the first word of each will be included in the list. [para] If the type definition includes [cmd "delegate typemethod *"], the list will include only the names of those implicitly delegated type methods that have been called at least once and are still in the type method cache. [para] If [arg pattern] is given, it's used as a [cmd {string match}] pattern; only names that match the pattern are returned. [call [cmd {$type}] [method {info args}] [arg method]] Returns a list containing the names of the arguments to the type's [arg method], in order. This method cannot be applied to delegated type methods. [call [cmd {$type}] [method {info body}] [arg method]] Returns the body of typemethod [arg method]. This method cannot be applied to delegated type methods. [call [cmd {$type}] [method {info default}] [arg method] [arg aname] [arg varname]] Returns a boolean value indicating whether the argument [arg aname] of the type's [arg method] has a default value ([const true]) or not ([const false]). If the argument has a default its value is placed into the variable [arg varname]. [call [cmd {$type}] [method {info instances}] [opt [arg pattern]]] Returns a list of the type's instances. For [cmd snit::type]s, it will be a list of fully-qualified instance names; for [cmd snit::widget]s, it will be a list of Tk widget names. [para] If [arg pattern] is given, it's used as a [cmd {string match}] pattern; only names that match the pattern are returned. [para] [emph "Snit 1.x Incompatibility:"] In Snit 1.x, the full multi-word names of hierarchical type methods are included in the return value. [call [cmd {$type}] [method destroy]] Destroys the type's instances, the type's namespace, and the type command itself. [list_end] [subsection {The Instance Command}] A Snit type or widget's [method create] type method creates objects of the type; each object has a unique name that is also a Tcl command. This command is used to access the object's methods and data, and has this form: [para] [list_begin definitions] [call [cmd {$object}] [arg method] [arg args...]] The [arg method] can be any of the [sectref "Standard Instance Methods"], or any instance method defined in the type definition. The subsequent [arg args] depend on the specific [arg method] chosen. [list_end] [subsection {Standard Instance Methods}] In addition to any delegated or locally-defined instance methods in the type's definition, all Snit objects will have at least the following subcommands: [para] [list_begin definitions] [call [cmd {$object}] [method configure] [opt [arg option]] [opt [arg value]] ...] Assigns new values to one or more options. If called with one argument, an [arg option] name, returns a list describing the option, as Tk widgets do; if called with no arguments, returns a list of lists describing all options, as Tk widgets do. [para] Warning: This information will be available for delegated options only if the component to which they are delegated has a [method configure] method that returns this same kind of information. [para] Note: Snit defines this method only if the type has at least one option. [call [cmd {$object}] [method configurelist] [arg optionlist]] Like [method configure], but takes one argument, a list of options and their values. It's mostly useful in the type constructor, but can be used anywhere. [para] Note: Snit defines this method only if the type has at least one option. [call [cmd {$object}] [method cget] [arg option]] Returns the option's value. [para] Note: Snit defines this method only if the type has at least one option. [call [cmd {$object}] [method destroy]] Destroys the object, calling the [cmd destructor] and freeing all related memory. [para] [emph Note:] The [method destroy] method isn't defined for [cmd snit::widget] or [cmd snit::widgetadaptor] objects; instances of these are destroyed by calling [package Tk]'s [cmd destroy] command, just as normal widgets are. [call [cmd {$object}] [method {info type}]] Returns the instance's type. [call [cmd {$object}] [method {info vars}] [opt [arg pattern]]] Returns a list of the object's instance variables (excluding Snit internal variables). The names are fully qualified. [para] If [arg pattern] is given, it's used as a [cmd {string match}] pattern; only names that match the pattern are returned. [call [cmd {$object}] [method {info typevars}] [opt [arg pattern]]] Returns a list of the object's type's type variables (excluding Snit internal variables). The names are fully qualified. [para] If [arg pattern] is given, it's used as a [cmd {string match}] pattern; only names that match the pattern are returned. [call [cmd {$object}] [method {info typemethods}] [opt [arg pattern]]] Returns a list of the names of the type's type methods. If the type has hierarchical type methods, whether locally-defined or delegated, only the first word of each will be included in the list. [para] If the type definition includes [cmd "delegate typemethod *"], the list will include only the names of those implicitly delegated type methods that have been called at least once and are still in the type method cache. [para] If [arg pattern] is given, it's used as a [cmd {string match}] pattern; only names that match the pattern are returned. [para] [emph "Snit 1.x Incompatibility:"] In Snit 1.x, the full multi-word names of hierarchical type methods are included in the return value. [call [cmd {$object}] [method {info options}] [opt [arg pattern]]] Returns a list of the object's option names. This always includes local options and explicitly delegated options. If unknown options are delegated as well, and if the component to which they are delegated responds to [cmd {$object configure}] like Tk widgets do, then the result will include all possible unknown options that can be delegated to the component. [para] If [arg pattern] is given, it's used as a [cmd {string match}] pattern; only names that match the pattern are returned. [para] Note that the return value might be different for different instances of the same type, if component object types can vary from one instance to another. [call [cmd {$object}] [method {info methods}] [opt [arg pattern]]] Returns a list of the names of the instance's methods. If the type has hierarchical methods, whether locally-defined or delegated, only the first word of each will be included in the list. [para] If the type definition includes [cmd "delegate method *"], the list will include only the names of those implicitly delegated methods that have been called at least once and are still in the method cache. [para] If [arg pattern] is given, it's used as a [cmd {string match}] pattern; only names that match the pattern are returned. [para] [emph "Snit 1.x Incompatibility:"] In Snit 1.x, the full multi-word names of hierarchical type methods are included in the return value. [call [cmd {$object}] [method {info args}] [arg method]] Returns a list containing the names of the arguments to the instance's [arg method], in order. This method cannot be applied to delegated methods. [call [cmd {$object}] [method {info body}] [arg method]] Returns the body of the instance's method [arg method]. This method cannot be applied to delegated methods. [call [cmd {$object}] [method {info default}] [arg method] [arg aname] [arg varname]] Returns a boolean value indicating whether the argument [arg aname] of the instance's [arg method] has a default value ([const true]) or not ([const false]). If the argument has a default its value is placed into the variable [arg varname]. [list_end] [subsection {Commands for use in Object Code}] Snit defines the following commands for use in your object code: that is, for use in type methods, instance methods, constructors, destructors, onconfigure handlers, oncget handlers, and procs. They do not reside in the ::snit:: namespace; instead, they are created with the type, and can be used without qualification. [list_begin definitions] [call [cmd mymethod] [arg name] [opt [arg args...]]] The [cmd mymethod] command is used for formatting callback commands to be passed to other objects. It returns a command that when called will invoke method [arg name] with the specified arguments, plus of course any arguments added by the caller. In other words, both of the following commands will cause the object's [method dosomething] method to be called when the [cmd {$button}] is pressed: [example { $button configure -command [list $self dosomething myargument] $button configure -command [mymethod dosomething myargument] }] The chief distinction between the two is that the latter form will not break if the object's command is renamed. [call [cmd mytypemethod] [arg name] [opt [arg args...]]] The [cmd mytypemethod] command is used for formatting callback commands to be passed to other objects. It returns a command that when called will invoke type method [arg name] with the specified arguments, plus of course any arguments added by the caller. In other words, both of the following commands will cause the object's [method dosomething] type method to be called when [cmd {$button}] is pressed: [example { $button configure -command [list $type dosomething myargument] $button configure -command [mytypemethod dosomething myargument] }] Type commands cannot be renamed, so in practice there's little difference between the two forms. [cmd mytypemethod] is provided for parallelism with [cmd mymethod]. [call [cmd myproc] [arg name] [opt [arg args...]]] The [cmd myproc] command is used for formatting callback commands to be passed to other objects. It returns a command that when called will invoke the type proc [arg name] with the specified arguments, plus of course any arguments added by the caller. In other words, both of the following commands will cause the object's [method dosomething] proc to be called when [cmd {$button}] is pressed: [example { $button configure -command [list ${type}::dosomething myargument] $button configure -command [myproc dosomething myargument] }] [call [cmd myvar] [arg name]] Given an instance variable name, returns the fully qualified name. Use this if you're passing the variable to some other object, e.g., as a [option -textvariable] to a Tk label widget. [call [cmd mytypevar] [arg name]] Given an type variable name, returns the fully qualified name. Use this if you're passing the variable to some other object, e.g., as a [option -textvariable] to a Tk label widget. [call [cmd from] [arg argvName] [arg option] [opt [arg defvalue]]] The [cmd from] command plucks an option value from a list of options and their values, such as is passed into a type's [cmd constructor]. [arg argvName] must be the name of a variable containing such a list; [arg option] is the name of the specific option. [para] [cmd from] looks for [arg option] in the option list. If it is found, it and its value are removed from the list, and the value is returned. If [arg option] doesn't appear in the list, then the [arg defvalue] is returned. If the option is locally-defined option, and [arg defvalue] is not specified, then the option's default value as specified in the type definition will be returned instead. [call [cmd install] [arg compName] [const using] [arg objType] [arg objName] [arg args...]] Creates a new object of type [arg objType] called [arg objName] and installs it as component [arg compName], as described in [sectref {Components and Delegation}]. Any additional [arg args...] are passed along with the name to the [arg objType] command. If this is a [cmd snit::type], then the following two commands are equivalent: [example { install myComp using myObjType $self.myComp args... set myComp [myObjType $self.myComp args...] }] Note that whichever method is used, [arg compName] must still be declared in the type definition using [cmd component], or must be referenced in at least one [cmd delegate] statement. [para] If this is a [cmd snit::widget] or [cmd snit::widgetadaptor], and if options have been delegated to component [arg compName], then those options will receive default values from the Tk option database. Note that it doesn't matter whether the component to be installed is a widget or not. See [sectref {The Tk Option Database}] for more information. [para] [cmd install] cannot be used to install type components; just assign the type component's command name to the type component's variable instead. [call [cmd installhull] [const using] [arg widgetType] [arg args...]] [call [cmd installhull] [arg name]] The constructor of a [cmd snit::widgetadaptor] must create a widget to be the object's hull component; the widget is installed as the hull component using this command. Note that the installed widget's name must be [const {$win}]. This command has two forms. [para] The first form specifies the [arg widgetType] and the [arg args...] (that is, the hardcoded option list) to use in creating the hull. Given this form, [cmd installhull] creates the hull widget, and initializes any options delegated to the hull from the Tk option database. [para] In the second form, the hull widget has already been created; note that its name must be "$win". In this case, the Tk option database is [emph not] queried for any options delegated to the hull. The longer form is preferred; however, the shorter form allows the programmer to adapt a widget created elsewhere, which is sometimes useful. For example, it can be used to adapt a "page" widget created by a [package BWidgets] tabbed notebook or pages manager widget. [para] See [sectref {The Tk Option Database}] for more information about [cmd snit::widgetadaptor]s and the option database. [call [cmd variable] [arg name]] Normally, instance variables are defined in the type definition along with the options, methods, and so forth; such instance variables are automatically visible in all instance code (e.g., method bodies). However, instance code can use the [cmd variable] command to declare instance variables that don't appear in the type definition, and also to bring variables from other namespaces into scope in the usual way. [para] It's generally clearest to define all instance variables in the type definition, and omit declaring them in methods and so forth. [para] Note that this is an instance-specific version of the standard Tcl [cmd ::variable] command. [call [cmd typevariable] [arg name]] Normally, type variables are defined in the type definition, along with the instance variables; such type variables are automatically visible in all of the type's code. However, type methods, instance methods and so forth can use [cmd typevariable] to declare type variables that don't appear in the type definition. [para] It's generally clearest to declare all type variables in the type definition, and omit declaring them in methods, type methods, etc. [call [cmd varname] [arg name]] [const Deprecated.] Use [cmd myvar] instead. [para] Given an instance variable name, returns the fully qualified name. Use this if you're passing the variable to some other object, e.g., as a [option -textvariable] to a Tk label widget. [call [cmd typevarname] [arg name]] [const Deprecated.] Use [cmd mytypevar] instead. [para] Given a type variable name, returns the fully qualified name. Use this if you're passing the type variable to some other object, e.g., as a [option -textvariable] to a Tk label widget. [call [cmd codename] [arg name]] [const Deprecated.] Use [cmd myproc] instead. Given the name of a proc (but not a type or instance method), returns the fully-qualified command name, suitable for passing as a callback. [list_end] [para] [subsection {Components and Delegation}] When an object includes other objects, as when a toolbar contains buttons or a GUI object contains an object that references a database, the included object is called a component. The standard way to handle component objects owned by a Snit object is to declare them using [cmd component], which creates a component instance variable. In the following example, a [cmd dog] object has a [cmd tail] object: [para] [example { snit::type dog { component mytail constructor {args} { set mytail [tail %AUTO% -partof $self] $self configurelist $args } method wag {} { $mytail wag } } snit::type tail { option -length 5 option -partof method wag {} { return "Wag, wag, wag."} } }] [para] Because the [cmd tail] object's name is stored in an instance variable, it's easily accessible in any method. [para] The [cmd install] command provides an alternate way to create and install the component: [para] [example { snit::type dog { component mytail constructor {args} { install mytail using tail %AUTO% -partof $self $self configurelist $args } method wag {} { $mytail wag } } }] [para] For [cmd snit::type]s, the two methods are equivalent; for [cmd snit::widget]s and [cmd snit::widgetadaptor]s, the [cmd install] command properly initializes the widget's options by querying [sectref {The Tk Option Database}]. [para] In the above examples, the [cmd dog] object's [method wag] method simply calls the [cmd tail] component's [method wag] method. In OO jargon, this is called delegation. Snit provides an easier way to do this: [para] [example { snit::type dog { delegate method wag to mytail constructor {args} { install mytail using tail %AUTO% -partof $self $self configurelist $args } } }] [para] The [cmd delegate] statement in the type definition implicitly defines the instance variable [var mytail] to hold the component's name (though it's good form to use [cmd component] to declare it explicitly); it also defines the [cmd dog] object's [method wag] method, delegating it to the [var mytail] component. [para] If desired, all otherwise unknown methods can be delegated to a specific component: [para] [example { snit::type dog { delegate method * to mytail constructor {args} { set mytail [tail %AUTO% -partof $self] $self configurelist $args } method bark { return "Bark, bark, bark!" } } }] [para] In this case, a [cmd dog] object will handle its own [method bark] method; but [method wag] will be passed along to [cmd mytail]. Any other method, being recognized by neither [cmd dog] nor [cmd tail], will simply raise an error. [para] Option delegation is similar to method delegation, except for the interactions with the Tk option database; this is described in [sectref "The Tk Option Database"]. [subsection {Type Components and Delegation}] The relationship between type components and instance components is identical to that between type variables and instance variables, and that between type methods and instance methods. Just as an instance component is an instance variable that holds the name of a command, so a type component is a type variable that holds the name of a command. In essence, a type component is a component that's shared by every instance of the type. [para] Just as [cmd "delegate method"] can be used to delegate methods to instance components, as described in [sectref "Components and Delegation"], so [cmd "delegate typemethod"] can be used to delegate type methods to type components. [para] Note also that as of Snit 0.95 [cmd "delegate method"] can delegate methods to both instance components and type components. [subsection {The Tk Option Database}] This section describes how Snit interacts with the Tk option database, and assumes the reader has a working knowledge of the option database and its uses. The book [emph {Practical Programming in Tcl and Tk}] by Welch et al has a good introduction to the option database, as does [emph {Effective Tcl/Tk Programming}]. [para] Snit is implemented so that most of the time it will simply do the right thing with respect to the option database, provided that the widget developer does the right thing by Snit. The body of this section goes into great deal about what Snit requires. The following is a brief statement of the requirements, for reference. [para] [list_begin itemized] [item] If the [cmd snit::widget]'s default widget class is not what is desired, set it explicitly using [cmd widgetclass] in the widget definition. [item] When defining or delegating options, specify the resource and class names explicitly when if the defaults aren't what you want. [item] Use [cmd {installhull using}] to install the hull for [cmd snit::widgetadaptor]s. [item] Use [cmd install] to install all other components. [list_end] [para] The interaction of Tk widgets with the option database is a complex thing; the interaction of Snit with the option database is even more so, and repays attention to detail. [para] [const {Setting the widget class:}] Every Tk widget has a widget class. For Tk widgets, the widget class name is the just the widget type name with an initial capital letter, e.g., the widget class for [cmd button] widgets is "Button". [para] Similarly, the widget class of a [cmd snit::widget] defaults to the unqualified type name with the first letter capitalized. For example, the widget class of [para] [example { snit::widget ::mylibrary::scrolledText { ... }}] [para] is "ScrolledText". The widget class can also be set explicitly using the [cmd widgetclass] statement within the [cmd snit::widget] definition. [para] Any widget can be used as the [cmd hulltype] provided that it supports the [const -class] option for changing its widget class name. See the discussion of the [cmd hulltype] command, above. The user may pass [const -class] to the widget at instantion. [para] The widget class of a [cmd snit::widgetadaptor] is just the widget class of its hull widget; this cannot be changed unless the hull widget supports [const -class], in which case it will usually make more sense to use [cmd snit::widget] rather than [cmd snit::widgetadaptor]. [para] [const {Setting option resource names and classes:}] In Tk, every option has three names: the option name, the resource name, and the class name. The option name begins with a hyphen and is all lowercase; it's used when creating widgets, and with the [cmd configure] and [cmd cget] commands. [para] The resource and class names are used to initialize option default values by querying the Tk option database. The resource name is usually just the option name minus the hyphen, but may contain uppercase letters at word boundaries; the class name is usually just the resource name with an initial capital, but not always. For example, here are the option, resource, and class names for several [cmd text] widget options: [para] [example { -background background Background -borderwidth borderWidth BorderWidth -insertborderwidth insertBorderWidth BorderWidth -padx padX Pad }] [para] As is easily seen, sometimes the resource and class names can be inferred from the option name, but not always. [para] Snit options also have a resource name and a class name. By default, these names follow the rule given above: the resource name is the option name without the hyphen, and the class name is the resource name with an initial capital. This is true for both locally-defined options and explicitly delegated options: [para] [example { snit::widget mywidget { option -background delegate option -borderwidth to hull delegate option * to text # ... } }] [para] In this case, the widget class name is "Mywidget". The widget has the following options: [option -background], which is locally defined, and [option -borderwidth], which is explicitly delegated; all other widgets are delegated to a component called "text", which is probably a Tk [cmd text] widget. If so, [cmd mywidget] has all the same options as a [cmd text] widget. The option, resource, and class names are as follows: [para] [example { -background background Background -borderwidth borderwidth Borderwidth -padx padX Pad }] [para] Note that the locally defined option, [option -background], happens to have the same three names as the standard Tk [option -background] option; and [option -pad], which is delegated implicitly to the [var text] component, has the same three names for [cmd mywidget] as it does for the [cmd text] widget. [option -borderwidth], on the other hand, has different resource and class names than usual, because the internal word "width" isn't capitalized. For consistency, it should be; this is done as follows: [para] [example { snit::widget mywidget { option -background delegate option {-borderwidth borderWidth} to hull delegate option * to text # ... } }] [para] The class name will default to "BorderWidth", as expected. [para] Suppose, however, that [cmd mywidget] also delegated [option -padx] and [option -pady] to the hull. In this case, both the resource name and the class name must be specified explicitly: [para] [example { snit::widget mywidget { option -background delegate option {-borderwidth borderWidth} to hull delegate option {-padx padX Pad} to hull delegate option {-pady padY Pad} to hull delegate option * to text # ... } }] [para] [const {Querying the option database:}] If you set your widgetclass and option names as described above, Snit will query the option database when each instance is created, and will generally do the right thing when it comes to querying the option database. The remainder of this section goes into the gory details. [para] [const {Initializing locally defined options:}] When an instance of a snit::widget is created, its locally defined options are initialized as follows: each option's resource and class names are used to query the Tk option database. If the result is non-empty, it is used as the option's default; otherwise, the default hardcoded in the type definition is used. In either case, the default can be overridden by the caller. For example, [para] [example { option add *Mywidget.texture pebbled snit::widget mywidget { option -texture smooth # ... } mywidget .mywidget -texture greasy }] [para] Here, [option -texture] would normally default to "smooth", but because of the entry added to the option database it defaults to "pebbled". However, the caller has explicitly overridden the default, and so the new widget will be "greasy". [para] [const {Initializing options delegated to the hull:}] A [cmd snit::widget]'s hull is a widget, and given that its class has been set it is expected to query the option database for itself. The only exception concerns options that are delegated to it with a different name. Consider the following code: [para] [example { option add *Mywidget.borderWidth 5 option add *Mywidget.relief sunken option add *Mywidget.hullbackground red option add *Mywidget.background green snit::widget mywidget { delegate option -borderwidth to hull delegate option -hullbackground to hull as -background delegate option * to hull # ... } mywidget .mywidget set A [.mywidget cget -relief] set B [.mywidget cget -hullbackground] set C [.mywidget cget -background] set D [.mywidget cget -borderwidth] }] [para] The question is, what are the values of variables A, B, C and D? [para] The value of A is "sunken". The hull is a Tk frame that has been given the widget class "Mywidget"; it will automatically query the option database and pick up this value. Since the [option -relief] option is implicitly delegated to the hull, Snit takes no action. [para] The value of B is "red". The hull will automatically pick up the value "green" for its [option -background] option, just as it picked up the [option -relief] value. However, Snit knows that [option -hullbackground] is mapped to the hull's [option -background] option; hence, it queries the option database for [option -hullbackground] and gets "red" and updates the hull accordingly. [para] The value of C is also "red", because [option -background] is implicitly delegated to the hull; thus, retrieving it is the same as retrieving [option -hullbackground]. Note that this case is unusual; in practice, [option -background] would probably be explicitly delegated to some other component. [para] The value of D is "5", but not for the reason you think. Note that as it is defined above, the resource name for [option -borderwidth] defaults to "borderwidth", whereas the option database entry is "borderWidth". As with [option -relief], the hull picks up its own [option -borderwidth] option before Snit does anything. Because the option is delegated under its own name, Snit assumes that the correct thing has happened, and doesn't worry about it any further. [para] For [cmd snit::widgetadaptor]s, the case is somewhat altered. Widget adaptors retain the widget class of their hull, and the hull is not created automatically by Snit. Instead, the [cmd snit::widgetadaptor] must call [cmd installhull] in its constructor. The normal way to do this is as follows: [para] [example { snit::widgetadaptor mywidget { # ... constructor {args} { # ... installhull using text -foreground white # } #... } }] [para] In this case, the [cmd installhull] command will create the hull using a command like this: [para] [example { set hull [text $win -foreground white] }] [para] The hull is a [cmd text] widget, so its widget class is "Text". Just as with [cmd snit::widget] hulls, Snit assumes that it will pick up all of its normal option values automatically; options delegated from a different name are initialized from the option database in the same way. [para] [const {Initializing options delegated to other components:}] Non-hull components are matched against the option database in two ways. First, a component widget remains a widget still, and therefore is initialized from the option database in the usual way. Second, the option database is queried for all options delegated to the component, and the component is initialized accordingly--provided that the [cmd install] command is used to create it. [para] Before option database support was added to Snit, the usual way to create a component was to simply create it in the constructor and assign its command name to the component variable: [para] [example { snit::widget mywidget { delegate option -background to myComp constructor {args} { set myComp [text $win.text -foreground black] } } }] [para] The drawback of this method is that Snit has no opportunity to initialize the component properly. Hence, the following approach is now used: [para] [example { snit::widget mywidget { delegate option -background to myComp constructor {args} { install myComp using text $win.text -foreground black } } }] [para] The [cmd install] command does the following: [para] [list_begin itemized] [item] Builds a list of the options explicitly included in the [cmd install] command -- in this case, [option -foreground]. [item] Queries the option database for all options delegated explicitly to the named component. [item] Creates the component using the specified command, after inserting into it a list of options and values read from the option database. Thus, the explicitly included options ([option -foreground]) will override anything read from the option database. [item] If the widget definition implicitly delegated options to the component using [cmd "delegate option *"], then Snit calls the newly created component's [cmd configure] method to receive a list of all of the component's options. From this Snit builds a list of options implicitly delegated to the component that were not explicitly included in the [cmd install] command. For all such options, Snit queries the option database and configures the component accordingly. [list_end] [para] [const {Non-widget components:}] The option database is never queried for [cmd snit::type]s, since it can only be queried given a Tk widget name. However, [cmd snit::widget]s can have non-widget components. And if options are delegated to those components, and if the [cmd install] command is used to install those components, then they will be initialized from the option database just as widget components are. [para] [subsection {Macros and Meta-programming}] The [cmd snit::macro] command enables a certain amount of meta-programming with Snit classes. For example, suppose you like to define properties: instance variables that have set/get methods. Your code might look like this: [example { snit::type dog { variable mood happy method getmood {} { return $mood } method setmood {newmood} { set mood $newmood } } }] That's nine lines of text per property. Or, you could define the following [cmd snit::macro]: [example { snit::macro property {name initValue} { variable $name $initValue method get$name {} "return $name" method set$name {value} "set $name \$value" } }] Note that a [cmd snit::macro] is just a normal Tcl proc defined in the slave interpreter used to compile type and widget definitions; as a result, it has access to all the commands used to define types and widgets. [para] Given this new macro, you can define a property in one line of code: [example { snit::type dog { property mood happy } }] Within a macro, the commands [cmd variable] and [cmd proc] refer to the Snit type-definition commands, not the standard Tcl commands. To get the standard Tcl commands, use [cmd _variable] and [cmd _proc]. [para] Because a single slave interpreter is used for compiling all Snit types and widgets in the application, there's the possibility of macro name collisions. If you're writing a reuseable package using Snit, and you use some [cmd snit::macro]s, define them in your package namespace: [example { snit::macro mypkg::property {name initValue} { ... } snit::type dog { mypkg::property mood happy } }] This leaves the global namespace open for application authors. [para] [subsection "Validation Types"] A validation type is an object that can be used to validate Tcl values of a particular kind. For example, [cmd snit::integer] is used to validate that a Tcl value is an integer. [para] Every validation type has a [method validate] method which is used to do the validation. This method must take a single argument, the value to be validated; further, it must do nothing if the value is valid, but throw an error if the value is invalid: [example { snit::integer validate 5 ;# Does nothing snit::integer validate 5.0 ;# Throws an error (not an integer!) }] [para] The [method validate] method will always return the validated value on success, and throw the [cmd -errorcode] INVALID on error. [para] Snit defines a family of validation types, all of which are implemented as [cmd snit::type]'s. They can be used as is; in addition, their instances serve as parameterized subtypes. For example, a probability is a number between 0.0 and 1.0 inclusive: [example { snit::double probability -min 0.0 -max 1.0 }] The example above creates an instance of [cmd snit::double]--a validation subtype--called [cmd probability], which can be used to validate probability values: [example { probability validate 0.5 ;# Does nothing probability validate 7.9 ;# Throws an error }] Validation subtypes can be defined explicitly, as in the above example; when a locally-defined option's [const -type] is specified, they may also be created on the fly: [example { snit::enum ::dog::breed -values {mutt retriever sheepdog} snit::type dog { # Define subtypes on the fly... option -breed -type { snit::enum -values {mutt retriever sheepdog} } # Or use predefined subtypes... option -breed -type ::dog::breed } }] [para] Any object that has a [method validate] method with the semantics described above can be used as a validation type; see [sectref "Defining Validation Types"] for information on how to define new ones. [para] Snit defines the following validation types: [list_begin definitions] [call [cmd snit::boolean] [const validate] [opt [arg value]]] [call [cmd snit::boolean] [arg name]] Validates Tcl boolean values: 1, 0, [const on], [const off], [const yes], [const no], [const true], [const false]. It's possible to define subtypes--that is, instances--of [cmd snit::boolean], but as it has no options there's no reason to do so. [call [cmd snit::double] [const validate] [opt [arg value]]] [call [cmd snit::double] [arg name] [opt "[arg option] [arg value]..."]] Validates floating-point values. Subtypes may be created with the following options: [list_begin definitions] [def "[const -min] [arg min]"] Specifies a floating-point minimum bound; a value is invalid if it is strictly less than [arg min]. [def "[const -max] [arg max]"] Specifies a floating-point maximum bound; a value is invalid if it is strictly greater than [arg max]. [list_end] [call [cmd snit::enum] [const validate] [opt [arg value]]] [call [cmd snit::enum] [arg name] [opt "[arg option] [arg value]..."]] Validates that a value comes from an enumerated list. The base type is of little use by itself, as only subtypes actually have an enumerated list to validate against. Subtypes may be created with the following options: [list_begin definitions] [def "[const -values] [arg list]"] Specifies a list of valid values. A value is valid if and only if it's included in the list. [list_end] [call [cmd snit::fpixels] [const validate] [opt [arg value]]] [call [cmd snit::fpixels] [arg name] [opt "[arg option] [arg value]..."]] [emph "Tk programs only."] Validates screen distances, in any of the forms accepted by [cmd "winfo fpixels"]. Subtypes may be created with the following options: [list_begin definitions] [def "[const -min] [arg min]"] Specifies a minimum bound; a value is invalid if it is strictly less than [arg min]. The bound may be expressed in any of the forms accepted by [cmd "winfo fpixels"]. [def "[const -max] [arg max]"] Specifies a maximum bound; a value is invalid if it is strictly greater than [arg max]. The bound may be expressed in any of the forms accepted by [cmd "winfo fpixels"]. [list_end] [call [cmd snit::integer] [const validate] [opt [arg value]]] [call [cmd snit::integer] [arg name] [opt "[arg option] [arg value]..."]] Validates integer values. Subtypes may be created with the following options: [list_begin definitions] [def "[const -min] [arg min]"] Specifies an integer minimum bound; a value is invalid if it is strictly less than [arg min]. [def "[const -max] [arg max]"] Specifies an integer maximum bound; a value is invalid if it is strictly greater than [arg max]. [list_end] [call [cmd snit::listtype] [const validate] [opt [arg value]]] [call [cmd snit::listtype] [arg name] [opt "[arg option] [arg value]..."]] Validates Tcl lists. Subtypes may be created with the following options: [list_begin definitions] [def "[const -minlen] [arg min]"] Specifies a minimum list length; the value is invalid if it has fewer than [arg min] elements. Defaults to 0. [def "[const -maxlen] [arg max]"] Specifies a maximum list length; the value is invalid if it more than [arg max] elements. [def "[const -type] [arg type]"] Specifies the type of the list elements; [arg type] must be the name of a validation type or subtype. In the following example, the value of [const -numbers] must be a list of integers. [example { option -numbers -type {snit::listtype -type snit::integer} }] Note that this option doesn't support defining new validation subtypes on the fly; that is, the following code will not work (yet, anyway): [example { option -numbers -type { snit::listtype -type {snit::integer -min 5} } }] Instead, define the subtype explicitly: [example { snit::integer gt4 -min 5 snit::type mytype { option -numbers -type {snit::listtype -type gt4} } }] [list_end] [call [cmd snit::pixels] [const validate] [opt [arg value]]] [call [cmd snit::pixels] [arg name] [opt "[arg option] [arg value]..."]] [emph "Tk programs only."] Validates screen distances, in any of the forms accepted by [cmd "winfo pixels"]. Subtypes may be created with the following options: [list_begin definitions] [def "[const -min] [arg min]"] Specifies a minimum bound; a value is invalid if it is strictly less than [arg min]. The bound may be expressed in any of the forms accepted by [cmd "winfo pixels"]. [def "[const -max] [arg max]"] Specifies a maximum bound; a value is invalid if it is strictly greater than [arg max]. The bound may be expressed in any of the forms accepted by [cmd "winfo pixels"]. [list_end] [call [cmd snit::stringtype] [const validate] [opt [arg value]]] [call [cmd snit::stringtype] [arg name] [opt "[arg option] [arg value]..."]] Validates Tcl strings. The base type is of little use by itself, since very Tcl value is also a valid string. Subtypes may be created with the following options: [list_begin definitions] [def "[const -minlen] [arg min]"] Specifies a minimum string length; the value is invalid if it has fewer than [arg min] characters. Defaults to 0. [def "[const -maxlen] [arg max]"] Specifies a maximum string length; the value is invalid if it has more than [arg max] characters. [def "[const -glob] [arg pattern]"] Specifies a [cmd "string match"] pattern; the value is invalid if it doesn't match the pattern. [def "[const -regexp] [arg regexp]"] Specifies a regular expression; the value is invalid if it doesn't match the regular expression. [def "[const -nocase] [arg flag]"] By default, both [const -glob] and [const -regexp] matches are case-sensitive. If [const -nocase] is set to true, then both [const -glob] and [const -regexp] matches are case-insensitive. [list_end] [call [cmd snit::window] [const validate] [opt [arg value]]] [call [cmd snit::window] [arg name]] [emph "Tk programs only."] Validates Tk window names. The value must cause [cmd "winfo exists"] to return true; otherwise, the value is invalid. It's possible to define subtypes--that is, instances--of [cmd snit::window], but as it has no options at present there's no reason to do so. [list_end] [para] [subsection "Defining Validation Types"] There are three ways to define a new validation type: as a subtype of one of Snit's validation types, as a validation type command, and as a full-fledged validation type similar to those provided by Snit. Defining subtypes of Snit's validation types is described above, under [sectref "Validation Types"]. [para] The next simplest way to create a new validation type is as a validation type command. A validation type is simply an object that has a [method validate] method; the [method validate] method must take one argument, a value, return the value if it is valid, and throw an error with [cmd -errorcode] INVALID if the value is invalid. This can be done with a simple [cmd proc]. For example, the [cmd snit::boolean] validate type could have been implemented like this: [example { proc ::snit::boolean {"validate" value} { if {![string is boolean -strict $value]} { return -code error -errorcode INVALID \ "invalid boolean \"$value\", should be one of: 1, 0, ..." } return $value } }] A validation type defined in this way cannot be subtyped, of course; but for many applications this will be sufficient. [para] Finally, one can define a full-fledged, subtype-able validation type as a [cmd snit::type]. Here's a skeleton to get you started: [example { snit::type myinteger { # First, define any options you'd like to use to define # subtypes. Give them defaults such that they won't take # effect if they aren't used, and marked them "read-only". # After all, you shouldn't be changing their values after # a subtype is defined. # # For example: option -min -default "" -readonly 1 option -max -default "" -readonly 1 # Next, define a "validate" type method which should do the # validation in the basic case. This will allow the # type command to be used as a validation type. typemethod validate {value} { if {![string is integer -strict $value]} { return -code error -errorcode INVALID \ "invalid value \"$value\", expected integer" } return $value } # Next, the constructor should validate the subtype options, # if any. Since they are all readonly, we don't need to worry # about validating the options on change. constructor {args} { # FIRST, get the options $self configurelist $args # NEXT, validate them. # I'll leave this to your imagination. } # Next, define a "validate" instance method; its job is to # validate values for subtypes. method validate {value} { # First, call the type method to do the basic validation. $type validate $value # Now we know it's a valid integer. if {("" != $options(-min) && $value < $options(-min)) || ("" != $options(-max) && $value > $options(-max))} { # It's out of range; format a detailed message about # the error, and throw it. set msg "...." return -code error -errorcode INVALID $msg } # Otherwise, if it's valid just return it. return $valid } } }] And now you have a type that can be subtyped. [para] The file "validate.tcl" in the Snit distribution defines all of Snit's validation types; you can find the complete implementation for [cmd snit::integer] and the other types there, to use as examples for your own types. [para] [section CAVEATS] If you have problems, find bugs, or new ideas you are hereby cordially invited to submit a report of your problem, bug, or idea as explained in the section [sectref {Bugs, Ideas, Feedback}] below. [para] Additionally, you might wish to join the Snit mailing list; see [uri http://www.wjduquette.com/snit] for details. [para] One particular area to watch is using [cmd snit::widgetadaptor] to adapt megawidgets created by other megawidget packages; correct widget destruction depends on the order of the bindings. The wisest course is simply not to do this. [section {KNOWN BUGS}] [list_begin itemized] [item] Error stack traces returned by Snit 1.x are extremely ugly and typically contain far too much information about Snit internals. The error messages are much improved in Snit 2.2. [item] Also see the Project Trackers as explained in the section [sectref {Bugs, Ideas, Feedback}] below. [list_end] [section HISTORY] During the course of developing Notebook (See [uri http://www.wjduquette.com/notebook]), my Tcl-based personal notebook application, I found I was writing it as a collection of objects. I wasn't using any particular object-oriented framework; I was just writing objects in pure Tcl following the guidelines in my Guide to Object Commands (see [uri http://www.wjduquette.com/tcl/objects.html]), along with a few other tricks I'd picked up since. And though it was working well, it quickly became tiresome because of the amount of boilerplate code associated with each new object type. [para] So that was one thing--tedium is a powerful motivator. But the other thing I noticed is that I wasn't using inheritance at all, and I wasn't missing it. Instead, I was using delegation: objects that created other objects and delegated methods to them. [para] And I said to myself, "This is getting tedious...there has got to be a better way." And one afternoon, on a whim, I started working on Snit, an object system that works the way Tcl works. Snit doesn't support inheritance, but it's great at delegation, and it makes creating megawidgets easy. [para] If you have any comments or suggestions (or bug reports!) don't hesitate to send me e-mail at [uri will@wjduquette.com]. In addition, there's a Snit mailing list; you can find out more about it at the Snit home page (see [uri http://www.wjduquette.com/snit]). [para] [section CREDITS] Snit has been designed and implemented from the very beginning by William H. Duquette. However, much credit belongs to the following people for using Snit and providing me with valuable feedback: Rolf Ade, Colin McCormack, Jose Nazario, Jeff Godfrey, Maurice Diamanti, Egon Pasztor, David S. Cargo, Tom Krehbiel, Michael Cleverly, Andreas Kupries, Marty Backe, Andy Goth, Jeff Hobbs, Brian Griffin, Donal Fellows, Miguel Sofer, Kenneth Green, and Anton Kovalenko. If I've forgotten anyone, my apologies; let me know and I'll add your name to the list. [vset CATEGORY snit] [include ../common-text/feedback.inc] [manpage_end] tcltk2/inst/tklibs/snit2.3.4/snit2.tcl0000644000176200001440000000141015017041713017022 0ustar liggesusers#----------------------------------------------------------------------- # TITLE: # snit2.tcl # # AUTHOR: # Will Duquette # # DESCRIPTION: # Snit's Not Incr Tcl, a simple object system in Pure Tcl. # # Snit 2.x Loader # # Copyright (C) 2003-2006 by William H. Duquette # This code is licensed as described in license.txt. # #----------------------------------------------------------------------- package require Tcl 8.5 9 # Define the snit namespace and save the library directory namespace eval ::snit:: { variable library [file dirname [info script]] } # Load the kernel. source [file join $::snit::library main2.tcl] # Load the library of Snit validation types. source [file join $::snit::library validate.tcl] package provide snit 2.3.4 tcltk2/inst/tklibs/snit2.3.4/main2.tcl0000644000176200001440000036442515017041713017013 0ustar liggesusers#----------------------------------------------------------------------- # TITLE: # main2.tcl # # AUTHOR: # Will Duquette # # DESCRIPTION: # Snit's Not Incr Tcl, a simple object system in Pure Tcl. # # Snit 2.x Compiler and Run-Time Library # # Copyright (C) 2003-2006 by William H. Duquette # This code is licensed as described in license.txt. # #----------------------------------------------------------------------- #----------------------------------------------------------------------- # Namespace namespace eval ::snit:: { namespace export \ compile type widget widgetadaptor typemethod method macro } #----------------------------------------------------------------------- # Some Snit variables namespace eval ::snit:: { variable reservedArgs {type selfns win self} # Widget classes which can be hulls (must have -class) variable hulltypes { toplevel tk::toplevel frame tk::frame ttk::frame labelframe tk::labelframe ttk::labelframe } } #----------------------------------------------------------------------- # Snit Type Implementation template namespace eval ::snit:: { # Template type definition: All internal and user-visible Snit # implementation code. # # The following placeholders will automatically be replaced with # the client's code, in two passes: # # First pass: # %COMPILEDDEFS% The compiled type definition. # # Second pass: # %TYPE% The fully qualified type name. # %IVARDECS% Instance variable declarations # %TVARDECS% Type variable declarations # %TCONSTBODY% Type constructor body # %INSTANCEVARS% The compiled instance variable initialization code. # %TYPEVARS% The compiled type variable initialization code. # This is the overall type template. variable typeTemplate # This is the normal type proc variable nominalTypeProc # This is the "-hastypemethods no" type proc variable simpleTypeProc } set ::snit::typeTemplate { #------------------------------------------------------------------- # The type's namespace definition and the user's type variables namespace eval %TYPE% {%TYPEVARS% } #---------------------------------------------------------------- # Commands for use in methods, typemethods, etc. # # These are implemented as aliases into the Snit runtime library. interp alias {} %TYPE%::installhull {} ::snit::RT.installhull %TYPE% interp alias {} %TYPE%::install {} ::snit::RT.install %TYPE% interp alias {} %TYPE%::typevariable {} ::variable interp alias {} %TYPE%::variable {} ::snit::RT.variable interp alias {} %TYPE%::mytypevar {} ::snit::RT.mytypevar %TYPE% interp alias {} %TYPE%::typevarname {} ::snit::RT.mytypevar %TYPE% interp alias {} %TYPE%::myvar {} ::snit::RT.myvar interp alias {} %TYPE%::varname {} ::snit::RT.myvar interp alias {} %TYPE%::codename {} ::snit::RT.codename %TYPE% interp alias {} %TYPE%::myproc {} ::snit::RT.myproc %TYPE% interp alias {} %TYPE%::mymethod {} ::snit::RT.mymethod interp alias {} %TYPE%::mytypemethod {} ::snit::RT.mytypemethod %TYPE% interp alias {} %TYPE%::from {} ::snit::RT.from %TYPE% #------------------------------------------------------------------- # Snit's internal variables namespace eval %TYPE% { # Array: General Snit Info # # ns: The type's namespace # hasinstances: T or F, from pragma -hasinstances. # simpledispatch: T or F, from pragma -hasinstances. # canreplace: T or F, from pragma -canreplace. # counter: Count of instances created so far. # widgetclass: Set by widgetclass statement. # hulltype: Hull type (frame or toplevel) for widgets only. # exceptmethods: Methods explicitly not delegated to * # excepttypemethods: Methods explicitly not delegated to * # tvardecs: Type variable declarations--for dynamic methods # ivardecs: Instance variable declarations--for dyn. methods typevariable Snit_info set Snit_info(ns) %TYPE%:: set Snit_info(hasinstances) 1 set Snit_info(simpledispatch) 0 set Snit_info(canreplace) 0 set Snit_info(counter) 0 set Snit_info(widgetclass) {} set Snit_info(hulltype) frame set Snit_info(exceptmethods) {} set Snit_info(excepttypemethods) {} set Snit_info(tvardecs) {%TVARDECS%} set Snit_info(ivardecs) {%IVARDECS%} # Array: Public methods of this type. # The index is the method name, or "*". # The value is [list $pattern $componentName], where # $componentName is "" for normal methods. typevariable Snit_typemethodInfo array unset Snit_typemethodInfo # Array: Public methods of instances of this type. # The index is the method name, or "*". # The value is [list $pattern $componentName], where # $componentName is "" for normal methods. typevariable Snit_methodInfo array unset Snit_methodInfo # Array: option information. See dictionary.txt. typevariable Snit_optionInfo array unset Snit_optionInfo set Snit_optionInfo(local) {} set Snit_optionInfo(delegated) {} set Snit_optionInfo(starcomp) {} set Snit_optionInfo(except) {} } #---------------------------------------------------------------- # Compiled Procs # # These commands are created or replaced during compilation: # Snit_instanceVars selfns # # Initializes the instance variables, if any. Called during # instance creation. proc %TYPE%::Snit_instanceVars {selfns} { %INSTANCEVARS% } # Type Constructor proc %TYPE%::Snit_typeconstructor {type} { %TVARDECS% namespace path [namespace parent $type] %TCONSTBODY% } #---------------------------------------------------------------- # Default Procs # # These commands might be replaced during compilation: # Snit_destructor type selfns win self # # Default destructor for the type. By default, it does # nothing. It's replaced by any user destructor. # For types, it's called by method destroy; for widgettypes, # it's called by a destroy event handler. proc %TYPE%::Snit_destructor {type selfns win self} { } #---------------------------------------------------------- # Compiled Definitions %COMPILEDDEFS% #---------------------------------------------------------- # Finally, call the Type Constructor %TYPE%::Snit_typeconstructor %TYPE% } #----------------------------------------------------------------------- # Type procs # # These procs expect the fully-qualified type name to be # substituted in for %TYPE%. # This is the nominal type proc. It supports typemethods and # delegated typemethods. set ::snit::nominalTypeProc { # WHD: Code for creating the type ensemble namespace eval %TYPE% { namespace ensemble create \ -unknown [list ::snit::RT.UnknownTypemethod %TYPE% ""] \ -prefixes 0 } } # This is the simplified type proc for when there are no typemethods # except create. In this case, it doesn't take a method argument; # the method is always "create". set ::snit::simpleTypeProc { # Type dispatcher function. Note: This function lives # in the parent of the %TYPE% namespace! All accesses to # %TYPE% variables and methods must be qualified! proc %TYPE% {args} { ::variable %TYPE%::Snit_info # FIRST, if the are no args, the single arg is %AUTO% if {[llength $args] == 0} { if {$Snit_info(isWidget)} { error "wrong \# args: should be \"%TYPE% name args\"" } lappend args %AUTO% } # NEXT, we're going to call the create method. # Pass along the return code unchanged. if {$Snit_info(isWidget)} { set command [list ::snit::RT.widget.typemethod.create %TYPE%] } else { set command [list ::snit::RT.type.typemethod.create %TYPE%] } set retval [catch {uplevel 1 $command $args} result] if {$retval} { if {$retval == 1} { global errorInfo global errorCode return -code error -errorinfo $errorInfo \ -errorcode $errorCode $result } else { return -code $retval $result } } return $result } } #======================================================================= # Snit Type Definition # # These are the procs used to define Snit types, widgets, and # widgetadaptors. #----------------------------------------------------------------------- # Snit Compilation Variables # # The following variables are used while Snit is compiling a type, # and are disposed afterwards. namespace eval ::snit:: { # The compiler variable contains the name of the slave interpreter # used to compile type definitions. variable compiler "" # The compile array accumulates information about the type or # widgettype being compiled. It is cleared before and after each # compilation. It has these indices: # # type: The name of the type being compiled, for use # in compilation procs. # defs: Compiled definitions, both standard and client. # which: type, widget, widgetadaptor # instancevars: Instance variable definitions and initializations. # ivprocdec: Instance variable proc declarations. # tvprocdec: Type variable proc declarations. # typeconstructor: Type constructor body. # widgetclass: The widgetclass, for snit::widgets, only # hasoptions: False, initially; set to true when first # option is defined. # localoptions: Names of local options. # delegatedoptions: Names of delegated options. # localmethods: Names of locally defined methods. # delegatesmethods: no if no delegated methods, yes otherwise. # hashierarchic : no if no hierarchic methods, yes otherwise. # components: Names of defined components. # typecomponents: Names of defined typecomponents. # typevars: Typevariable definitions and initializations. # varnames: Names of instance variables # typevarnames Names of type variables # hasconstructor False, initially; true when constructor is # defined. # resource-$opt The option's resource name # class-$opt The option's class # -default-$opt The option's default value # -validatemethod-$opt The option's validate method # -configuremethod-$opt The option's configure method # -cgetmethod-$opt The option's cget method. # -hastypeinfo The -hastypeinfo pragma # -hastypedestroy The -hastypedestroy pragma # -hastypemethods The -hastypemethods pragma # -hasinfo The -hasinfo pragma # -hasinstances The -hasinstances pragma # -simpledispatch The -simpledispatch pragma WHD: OBSOLETE # -canreplace The -canreplace pragma variable compile # This variable accumulates method dispatch information; it has # the same structure as the %TYPE%::Snit_methodInfo array, and is # used to initialize it. variable methodInfo # This variable accumulates typemethod dispatch information; it has # the same structure as the %TYPE%::Snit_typemethodInfo array, and is # used to initialize it. variable typemethodInfo # The following variable lists the reserved type definition statement # names, e.g., the names you can't use as macros. It's built at # compiler definition time using "info commands". variable reservedwords {} } #----------------------------------------------------------------------- # type compilation commands # # The type and widgettype commands use a slave interpreter to compile # the type definition. These are the procs # that are aliased into it. # Initialize the compiler proc ::snit::Comp.Init {} { variable compiler variable reservedwords if {$compiler eq ""} { # Create the compiler's interpreter set compiler [interp create] # Initialize the interpreter $compiler eval { catch {close stdout} catch {close stderr} catch {close stdin} # Load package information # TBD: see if this can be moved outside. # @mdgen NODEP: ::snit::__does_not_exist__ catch {package require ::snit::__does_not_exist__} # Protect some Tcl commands our type definitions # will shadow. rename proc _proc rename variable _variable } # Define compilation aliases. $compiler alias pragma ::snit::Comp.statement.pragma $compiler alias widgetclass ::snit::Comp.statement.widgetclass $compiler alias hulltype ::snit::Comp.statement.hulltype $compiler alias constructor ::snit::Comp.statement.constructor $compiler alias destructor ::snit::Comp.statement.destructor $compiler alias option ::snit::Comp.statement.option $compiler alias oncget ::snit::Comp.statement.oncget $compiler alias onconfigure ::snit::Comp.statement.onconfigure $compiler alias method ::snit::Comp.statement.method $compiler alias typemethod ::snit::Comp.statement.typemethod $compiler alias typeconstructor ::snit::Comp.statement.typeconstructor $compiler alias proc ::snit::Comp.statement.proc $compiler alias typevariable ::snit::Comp.statement.typevariable $compiler alias variable ::snit::Comp.statement.variable $compiler alias typecomponent ::snit::Comp.statement.typecomponent $compiler alias component ::snit::Comp.statement.component $compiler alias delegate ::snit::Comp.statement.delegate $compiler alias expose ::snit::Comp.statement.expose # Get the list of reserved words set reservedwords [$compiler eval {info commands}] } } # Compile a type definition, and return the results as a list of two # items: the fully-qualified type name, and a script that will define # the type when executed. # # which type, widget, or widgetadaptor # type the type name # body the type definition proc ::snit::Comp.Compile {which type body} { variable typeTemplate variable nominalTypeProc variable simpleTypeProc variable compile variable compiler variable methodInfo variable typemethodInfo # FIRST, qualify the name. if {![string match "::*" $type]} { # Get caller's namespace; # append :: if not global namespace. set ns [uplevel 2 [list namespace current]] if {"::" != $ns} { append ns "::" } set type "$ns$type" } # NEXT, create and initialize the compiler, if needed. Comp.Init # NEXT, initialize the class data array unset methodInfo array unset typemethodInfo array unset compile set compile(type) $type set compile(defs) {} set compile(which) $which set compile(hasoptions) no set compile(localoptions) {} set compile(instancevars) {} set compile(typevars) {} set compile(delegatedoptions) {} set compile(ivprocdec) {} set compile(tvprocdec) {} set compile(typeconstructor) {} set compile(widgetclass) {} set compile(hulltype) {} set compile(localmethods) {} set compile(delegatesmethods) no set compile(hashierarchic) no set compile(components) {} set compile(typecomponents) {} set compile(varnames) {} set compile(typevarnames) {} set compile(hasconstructor) no set compile(-hastypedestroy) yes set compile(-hastypeinfo) yes set compile(-hastypemethods) yes set compile(-hasinfo) yes set compile(-hasinstances) yes set compile(-canreplace) no set isWidget [string match widget* $which] set isWidgetAdaptor [string match widgetadaptor $which] # NEXT, Evaluate the type's definition in the class interpreter. $compiler eval $body # NEXT, Add the standard definitions append compile(defs) \ "\nset %TYPE%::Snit_info(isWidget) $isWidget\n" append compile(defs) \ "\nset %TYPE%::Snit_info(isWidgetAdaptor) $isWidgetAdaptor\n" # Indicate whether the type can create instances that replace # existing commands. append compile(defs) "\nset %TYPE%::Snit_info(canreplace) $compile(-canreplace)\n" # Check pragmas for conflict. if {!$compile(-hastypemethods) && !$compile(-hasinstances)} { error "$which $type has neither typemethods nor instances" } # If there are typemethods, define the standard typemethods and # the nominal type proc. Otherwise define the simple type proc. if {$compile(-hastypemethods)} { # Add the info typemethod unless the pragma forbids it. if {$compile(-hastypeinfo)} { Comp.statement.delegate typemethod info \ using {::snit::RT.typemethod.info %t} } # Add the destroy typemethod unless the pragma forbids it. if {$compile(-hastypedestroy)} { Comp.statement.delegate typemethod destroy \ using {::snit::RT.typemethod.destroy %t} } # Add the nominal type proc. append compile(defs) $nominalTypeProc } else { # Add the simple type proc. append compile(defs) $simpleTypeProc } # Add standard methods/typemethods that only make sense if the # type has instances. if {$compile(-hasinstances)} { # Add the info method unless the pragma forbids it. if {$compile(-hasinfo)} { Comp.statement.delegate method info \ using {::snit::RT.method.info %t %n %w %s} } # Add the option handling stuff if there are any options. if {$compile(hasoptions)} { Comp.statement.variable options Comp.statement.delegate method cget \ using {::snit::RT.method.cget %t %n %w %s} Comp.statement.delegate method configurelist \ using {::snit::RT.method.configurelist %t %n %w %s} Comp.statement.delegate method configure \ using {::snit::RT.method.configure %t %n %w %s} } # Add a default constructor, if they haven't already defined one. # If there are options, it will configure args; otherwise it # will do nothing. if {!$compile(hasconstructor)} { if {$compile(hasoptions)} { Comp.statement.constructor {args} { $self configurelist $args } } else { Comp.statement.constructor {} {} } } if {!$isWidget} { Comp.statement.delegate method destroy \ using {::snit::RT.method.destroy %t %n %w %s} Comp.statement.delegate typemethod create \ using {::snit::RT.type.typemethod.create %t} } else { Comp.statement.delegate typemethod create \ using {::snit::RT.widget.typemethod.create %t} } # Save the method info. append compile(defs) \ "\narray set %TYPE%::Snit_methodInfo [list [array get methodInfo]]\n" } else { append compile(defs) "\nset %TYPE%::Snit_info(hasinstances) 0\n" } # NEXT, compiling the type definition built up a set of information # about the type's locally defined options; add this information to # the compiled definition. Comp.SaveOptionInfo # NEXT, compiling the type definition built up a set of information # about the typemethods; save the typemethod info. append compile(defs) \ "\narray set %TYPE%::Snit_typemethodInfo [list [array get typemethodInfo]]\n" # NEXT, if this is a widget define the hull component if it isn't # already defined. if {$isWidget} { Comp.DefineComponent hull } # NEXT, substitute the compiled definition into the type template # to get the type definition script. set defscript [Expand $typeTemplate \ %COMPILEDDEFS% $compile(defs)] # NEXT, substitute the defined macros into the type definition script. # This is done as a separate step so that the compile(defs) can # contain the macros defined below. set defscript [Expand $defscript \ %TYPE% $type \ %IVARDECS% $compile(ivprocdec) \ %TVARDECS% $compile(tvprocdec) \ %TCONSTBODY% $compile(typeconstructor) \ %INSTANCEVARS% $compile(instancevars) \ %TYPEVARS% $compile(typevars) \ ] array unset compile return [list $type $defscript] } # Information about locally-defined options is accumulated during # compilation, but not added to the compiled definition--the option # statement can appear multiple times, so it's easier this way. # This proc fills in Snit_optionInfo with the accumulated information. # # It also computes the option's resource and class names if needed. # # Note that the information for delegated options was put in # Snit_optionInfo during compilation. proc ::snit::Comp.SaveOptionInfo {} { variable compile foreach option $compile(localoptions) { if {$compile(resource-$option) eq ""} { set compile(resource-$option) [string range $option 1 end] } if {$compile(class-$option) eq ""} { set compile(class-$option) [Capitalize $compile(resource-$option)] } # NOTE: Don't verify that the validate, configure, and cget # values name real methods; the methods might be defined outside # the typedefinition using snit::method. Mappend compile(defs) { # Option %OPTION% lappend %TYPE%::Snit_optionInfo(local) %OPTION% set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 1 set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RESOURCE% set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS% set %TYPE%::Snit_optionInfo(default-%OPTION%) %DEFAULT% set %TYPE%::Snit_optionInfo(validate-%OPTION%) %VALIDATE% set %TYPE%::Snit_optionInfo(configure-%OPTION%) %CONFIGURE% set %TYPE%::Snit_optionInfo(cget-%OPTION%) %CGET% set %TYPE%::Snit_optionInfo(readonly-%OPTION%) %READONLY% set %TYPE%::Snit_optionInfo(typespec-%OPTION%) %TYPESPEC% } %OPTION% $option \ %RESOURCE% $compile(resource-$option) \ %CLASS% $compile(class-$option) \ %DEFAULT% [list $compile(-default-$option)] \ %VALIDATE% [list $compile(-validatemethod-$option)] \ %CONFIGURE% [list $compile(-configuremethod-$option)] \ %CGET% [list $compile(-cgetmethod-$option)] \ %READONLY% $compile(-readonly-$option) \ %TYPESPEC% [list $compile(-type-$option)] } } # Evaluates a compiled type definition, thus making the type available. proc ::snit::Comp.Define {compResult} { # The compilation result is a list containing the fully qualified # type name and a script to evaluate to define the type. set type [lindex $compResult 0] set defscript [lindex $compResult 1] # Execute the type definition script. # Consider using namespace eval %TYPE%. See if it's faster. if {[catch {eval $defscript} result]} { namespace delete $type catch {rename $type ""} error $result } return $type } # Sets pragma options which control how the type is defined. proc ::snit::Comp.statement.pragma {args} { variable compile set errRoot "Error in \"pragma...\"" foreach {opt val} $args { switch -exact -- $opt { -hastypeinfo - -hastypedestroy - -hastypemethods - -hasinstances - -simpledispatch - -hasinfo - -canreplace { if {![string is boolean -strict $val]} { error "$errRoot, \"$opt\" requires a boolean value" } set compile($opt) $val } default { error "$errRoot, unknown pragma" } } } } # Defines a widget's option class name. # This statement is only available for snit::widgets, # not for snit::types or snit::widgetadaptors. proc ::snit::Comp.statement.widgetclass {name} { variable compile # First, widgetclass can only be set for true widgets if {"widget" != $compile(which)} { error "widgetclass cannot be set for snit::$compile(which)s" } # Next, validate the option name. We'll require that it begin # with an uppercase letter. set initial [string index $name 0] if {![string is upper $initial]} { error "widgetclass \"$name\" does not begin with an uppercase letter" } if {"" != $compile(widgetclass)} { error "too many widgetclass statements" } # Next, save it. Mappend compile(defs) { set %TYPE%::Snit_info(widgetclass) %WIDGETCLASS% } %WIDGETCLASS% [list $name] set compile(widgetclass) $name } # Defines a widget's hull type. # This statement is only available for snit::widgets, # not for snit::types or snit::widgetadaptors. proc ::snit::Comp.statement.hulltype {name} { variable compile variable hulltypes # First, hulltype can only be set for true widgets if {"widget" != $compile(which)} { error "hulltype cannot be set for snit::$compile(which)s" } # Next, it must be one of the valid hulltypes (frame, toplevel, ...) if {[lsearch -exact $hulltypes [string trimleft $name :]] == -1} { error "invalid hulltype \"$name\", should be one of\ [join $hulltypes {, }]" } if {"" != $compile(hulltype)} { error "too many hulltype statements" } # Next, save it. Mappend compile(defs) { set %TYPE%::Snit_info(hulltype) %HULLTYPE% } %HULLTYPE% $name set compile(hulltype) $name } # Defines a constructor. proc ::snit::Comp.statement.constructor {arglist body} { variable compile CheckArgs "constructor" $arglist # Next, add a magic reference to self. set arglist [concat type selfns win self $arglist] # Next, add variable declarations to body: set body "%TVARDECS%\n%IVARDECS%\n$body" set compile(hasconstructor) yes append compile(defs) "proc %TYPE%::Snit_constructor [list $arglist] [list $body]\n" } # Defines a destructor. proc ::snit::Comp.statement.destructor {body} { variable compile # Next, add variable declarations to body: set body "%TVARDECS%\n%IVARDECS%\n$body" append compile(defs) "proc %TYPE%::Snit_destructor {type selfns win self} [list $body]\n\n" } # Defines a type option. The option value can be a triple, specifying # the option's -name, resource name, and class name. proc ::snit::Comp.statement.option {optionDef args} { variable compile # First, get the three option names. set option [lindex $optionDef 0] set resourceName [lindex $optionDef 1] set className [lindex $optionDef 2] set errRoot "Error in \"option [list $optionDef]...\"" # Next, validate the option name. if {![Comp.OptionNameIsValid $option]} { error "$errRoot, badly named option \"$option\"" } if {$option in $compile(delegatedoptions)} { error "$errRoot, cannot define \"$option\" locally, it has been delegated" } if {!($option in $compile(localoptions))} { # Remember that we've seen this one. set compile(hasoptions) yes lappend compile(localoptions) $option # Initialize compilation info for this option. set compile(resource-$option) "" set compile(class-$option) "" set compile(-default-$option) "" set compile(-validatemethod-$option) "" set compile(-configuremethod-$option) "" set compile(-cgetmethod-$option) "" set compile(-readonly-$option) 0 set compile(-type-$option) "" } # NEXT, see if we have a resource name. If so, make sure it # isn't being redefined differently. if {$resourceName ne ""} { if {$compile(resource-$option) eq ""} { # If it's undefined, just save the value. set compile(resource-$option) $resourceName } elseif {$resourceName ne $compile(resource-$option)} { # It's been redefined differently. error "$errRoot, resource name redefined from \"$compile(resource-$option)\" to \"$resourceName\"" } } # NEXT, see if we have a class name. If so, make sure it # isn't being redefined differently. if {$className ne ""} { if {$compile(class-$option) eq ""} { # If it's undefined, just save the value. set compile(class-$option) $className } elseif {$className ne $compile(class-$option)} { # It's been redefined differently. error "$errRoot, class name redefined from \"$compile(class-$option)\" to \"$className\"" } } # NEXT, handle the args; it's not an error to redefine these. if {[llength $args] == 1} { set compile(-default-$option) [lindex $args 0] } else { foreach {optopt val} $args { switch -exact -- $optopt { -default - -validatemethod - -configuremethod - -cgetmethod { set compile($optopt-$option) $val } -type { set compile($optopt-$option) $val if {[llength $val] == 1} { # The type spec *is* the validation object append compile(defs) \ "\nset %TYPE%::Snit_optionInfo(typeobj-$option) [list $val]\n" } else { # Compilation the creation of the validation object set cmd [linsert $val 1 %TYPE%::Snit_TypeObj_%AUTO%] append compile(defs) \ "\nset %TYPE%::Snit_optionInfo(typeobj-$option) \[$cmd\]\n" } } -readonly { if {![string is boolean -strict $val]} { error "$errRoot, -readonly requires a boolean, got \"$val\"" } set compile($optopt-$option) $val } default { error "$errRoot, unknown option definition option \"$optopt\"" } } } } } # 1 if the option name is valid, 0 otherwise. proc ::snit::Comp.OptionNameIsValid {option} { if {![string match {-*} $option] || [string match {*[A-Z ]*} $option]} { return 0 } return 1 } # Defines an option's cget handler proc ::snit::Comp.statement.oncget {option body} { variable compile set errRoot "Error in \"oncget $option...\"" if {[lsearch -exact $compile(delegatedoptions) $option] != -1} { return -code error "$errRoot, option \"$option\" is delegated" } if {[lsearch -exact $compile(localoptions) $option] == -1} { return -code error "$errRoot, option \"$option\" unknown" } Comp.statement.method _cget$option {_option} $body Comp.statement.option $option -cgetmethod _cget$option } # Defines an option's configure handler. proc ::snit::Comp.statement.onconfigure {option arglist body} { variable compile if {[lsearch -exact $compile(delegatedoptions) $option] != -1} { return -code error "onconfigure $option: option \"$option\" is delegated" } if {[lsearch -exact $compile(localoptions) $option] == -1} { return -code error "onconfigure $option: option \"$option\" unknown" } if {[llength $arglist] != 1} { error \ "onconfigure $option handler should have one argument, got \"$arglist\"" } CheckArgs "onconfigure $option" $arglist # Next, add a magic reference to the option name set arglist [concat _option $arglist] Comp.statement.method _configure$option $arglist $body Comp.statement.option $option -configuremethod _configure$option } # Defines an instance method. proc ::snit::Comp.statement.method {method arglist body} { variable compile variable methodInfo # FIRST, check the method name against previously defined # methods. Comp.CheckMethodName $method 0 ::snit::methodInfo \ "Error in \"method [list $method]...\"" if {[llength $method] > 1} { set compile(hashierarchic) yes } # Remeber this method lappend compile(localmethods) $method CheckArgs "method [list $method]" $arglist # Next, add magic references to type and self. set arglist [concat type selfns win self $arglist] # Next, add variable declarations to body: set body "%TVARDECS%\n%IVARDECS%\n# END snit method prolog\n$body" # Next, save the definition script. if {[llength $method] == 1} { set methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""} Mappend compile(defs) { proc %TYPE%::Snit_method%METHOD% %ARGLIST% %BODY% } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body] } else { set methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""} Mappend compile(defs) { proc %TYPE%::Snit_hmethod%JMETHOD% %ARGLIST% %BODY% } %JMETHOD% [join $method _] %ARGLIST% [list $arglist] \ %BODY% [list $body] } } # Check for name collisions; save prefix information. # # method The name of the method or typemethod. # delFlag 1 if delegated, 0 otherwise. # infoVar The fully qualified name of the array containing # information about the defined methods. # errRoot The root string for any error messages. proc ::snit::Comp.CheckMethodName {method delFlag infoVar errRoot} { upvar $infoVar methodInfo # FIRST, make sure the method name is a valid Tcl list. if {[catch {lindex $method 0}]} { error "$errRoot, the name \"$method\" must have list syntax." } # NEXT, check whether we can define it. if {![catch {set methodInfo($method)} data]} { # We can't redefine methods with submethods. if {[lindex $data 0] == 1} { error "$errRoot, \"$method\" has submethods." } # You can't delegate a method that's defined locally, # and you can't define a method locally if it's been delegated. if {$delFlag && [lindex $data 2] eq ""} { error "$errRoot, \"$method\" has been defined locally." } elseif {!$delFlag && [lindex $data 2] ne ""} { error "$errRoot, \"$method\" has been delegated" } } # Handle hierarchical case. if {[llength $method] > 1} { set prefix {} set tokens $method while {[llength $tokens] > 1} { lappend prefix [lindex $tokens 0] set tokens [lrange $tokens 1 end] if {![catch {set methodInfo($prefix)} result]} { # Prefix is known. If it's not a prefix, throw an # error. if {[lindex $result 0] == 0} { error "$errRoot, \"$prefix\" has no submethods." } } set methodInfo($prefix) [list 1] } } } # Defines a typemethod method. proc ::snit::Comp.statement.typemethod {method arglist body} { variable compile variable typemethodInfo # FIRST, check the typemethod name against previously defined # typemethods. Comp.CheckMethodName $method 0 ::snit::typemethodInfo \ "Error in \"typemethod [list $method]...\"" CheckArgs "typemethod $method" $arglist # First, add magic reference to type. set arglist [concat type $arglist] # Next, add typevariable declarations to body: set body "%TVARDECS%\n# END snit method prolog\n$body" # Next, save the definition script if {[llength $method] == 1} { set typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""} Mappend compile(defs) { proc %TYPE%::Snit_typemethod%METHOD% %ARGLIST% %BODY% } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body] } else { set typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""} Mappend compile(defs) { proc %TYPE%::Snit_htypemethod%JMETHOD% %ARGLIST% %BODY% } %JMETHOD% [join $method _] \ %ARGLIST% [list $arglist] %BODY% [list $body] } } # Defines a type constructor. proc ::snit::Comp.statement.typeconstructor {body} { variable compile if {"" != $compile(typeconstructor)} { error "too many typeconstructors" } set compile(typeconstructor) $body } # Defines a static proc in the type's namespace. proc ::snit::Comp.statement.proc {proc arglist body} { variable compile # If "ns" is defined, the proc can see instance variables. if {[lsearch -exact $arglist selfns] != -1} { # Next, add instance variable declarations to body: set body "%IVARDECS%\n$body" } # The proc can always see typevariables. set body "%TVARDECS%\n$body" append compile(defs) " # Proc $proc proc [list %TYPE%::$proc $arglist $body] " } # Defines a static variable in the type's namespace. proc ::snit::Comp.statement.typevariable {name args} { variable compile set errRoot "Error in \"typevariable $name...\"" set len [llength $args] if {$len > 2 || ($len == 2 && [lindex $args 0] ne "-array")} { error "$errRoot, too many initializers" } if {[lsearch -exact $compile(varnames) $name] != -1} { error "$errRoot, \"$name\" is already an instance variable" } lappend compile(typevarnames) $name if {$len == 1} { append compile(typevars) \ "\n\t [list ::variable $name [lindex $args 0]]" } elseif {$len == 2} { append compile(typevars) \ "\n\t [list ::variable $name]" append compile(typevars) \ "\n\t [list array set $name [lindex $args 1]]" } else { append compile(typevars) \ "\n\t [list ::variable $name]" } if {$compile(tvprocdec) eq ""} { set compile(tvprocdec) "\n\t" append compile(tvprocdec) "namespace upvar [list $compile(type)]" } append compile(tvprocdec) " [list $name $name]" } # Defines an instance variable; the definition will go in the # type's create typemethod. proc ::snit::Comp.statement.variable {name args} { variable compile set errRoot "Error in \"variable $name...\"" set len [llength $args] if {$len > 2 || ($len == 2 && [lindex $args 0] ne "-array")} { error "$errRoot, too many initializers" } if {[lsearch -exact $compile(typevarnames) $name] != -1} { error "$errRoot, \"$name\" is already a typevariable" } lappend compile(varnames) $name # Add a ::variable to instancevars, so that ::variable is used # at least once; ::variable makes the variable visible to # [info vars] even if no value is assigned. append compile(instancevars) "\n" Mappend compile(instancevars) {::variable ${selfns}::%N} %N $name if {$len == 1} { append compile(instancevars) \ "\nset $name [list [lindex $args 0]]\n" } elseif {$len == 2} { append compile(instancevars) \ "\narray set $name [list [lindex $args 1]]\n" } if {$compile(ivprocdec) eq ""} { set compile(ivprocdec) "\n\t" append compile(ivprocdec) {namespace upvar $selfns} } append compile(ivprocdec) " [list $name $name]" } # Defines a typecomponent, and handles component options. # # component The logical name of the delegate # args options. proc ::snit::Comp.statement.typecomponent {component args} { variable compile set errRoot "Error in \"typecomponent $component...\"" # FIRST, define the component Comp.DefineTypecomponent $component $errRoot # NEXT, handle the options. set publicMethod "" set inheritFlag 0 foreach {opt val} $args { switch -exact -- $opt { -public { set publicMethod $val } -inherit { set inheritFlag $val if {![string is boolean $inheritFlag]} { error "typecomponent $component -inherit: expected boolean value, got \"$val\"" } } default { error "typecomponent $component: Invalid option \"$opt\"" } } } # NEXT, if -public specified, define the method. if {$publicMethod ne ""} { Comp.statement.delegate typemethod [list $publicMethod *] to $component } # NEXT, if "-inherit 1" is specified, delegate typemethod * to # this component. if {$inheritFlag} { Comp.statement.delegate typemethod "*" to $component } } # Defines a name to be a typecomponent # # The name becomes a typevariable; in addition, it gets a # write trace so that when it is set, all of the component mechanisms # get updated. # # component The component name proc ::snit::Comp.DefineTypecomponent {component {errRoot "Error"}} { variable compile if {[lsearch -exact $compile(varnames) $component] != -1} { error "$errRoot, \"$component\" is already an instance variable" } if {[lsearch -exact $compile(typecomponents) $component] == -1} { # Remember we've done this. lappend compile(typecomponents) $component # Make it a type variable with no initial value Comp.statement.typevariable $component "" # Add a write trace to do the component thing. Mappend compile(typevars) { trace add variable %COMP% write \ [list ::snit::RT.TypecomponentTrace [list %TYPE%] %COMP%] } %TYPE% $compile(type) %COMP% $component } } # Defines a component, and handles component options. # # component The logical name of the delegate # args options. # # TBD: Ideally, it should be possible to call this statement multiple # times, possibly changing the option values. To do that, I'd need # to cache the option values and not act on them until *after* I'd # read the entire type definition. proc ::snit::Comp.statement.component {component args} { variable compile set errRoot "Error in \"component $component...\"" # FIRST, define the component Comp.DefineComponent $component $errRoot # NEXT, handle the options. set publicMethod "" set inheritFlag 0 foreach {opt val} $args { switch -exact -- $opt { -public { set publicMethod $val } -inherit { set inheritFlag $val if {![string is boolean $inheritFlag]} { error "component $component -inherit: expected boolean value, got \"$val\"" } } default { error "component $component: Invalid option \"$opt\"" } } } # NEXT, if -public specified, define the method. if {$publicMethod ne ""} { Comp.statement.delegate method [list $publicMethod *] to $component } # NEXT, if -inherit is specified, delegate method/option * to # this component. if {$inheritFlag} { Comp.statement.delegate method "*" to $component Comp.statement.delegate option "*" to $component } } # Defines a name to be a component # # The name becomes an instance variable; in addition, it gets a # write trace so that when it is set, all of the component mechanisms # get updated. # # component The component name proc ::snit::Comp.DefineComponent {component {errRoot "Error"}} { variable compile if {[lsearch -exact $compile(typevarnames) $component] != -1} { error "$errRoot, \"$component\" is already a typevariable" } if {[lsearch -exact $compile(components) $component] == -1} { # Remember we've done this. lappend compile(components) $component # Make it an instance variable with no initial value Comp.statement.variable $component "" # Add a write trace to do the component thing. Mappend compile(instancevars) { trace add variable ${selfns}::%COMP% write \ [list ::snit::RT.ComponentTrace [list %TYPE%] $selfns %COMP%] } %TYPE% $compile(type) %COMP% $component } } # Creates a delegated method, typemethod, or option. proc ::snit::Comp.statement.delegate {what name args} { # FIRST, dispatch to correct handler. switch $what { typemethod { Comp.DelegatedTypemethod $name $args } method { Comp.DelegatedMethod $name $args } option { Comp.DelegatedOption $name $args } default { error "Error in \"delegate $what $name...\", \"$what\"?" } } if {([llength $args] % 2) != 0} { error "Error in \"delegate $what $name...\", invalid syntax" } } # Creates a delegated typemethod delegating it to a particular # typecomponent or an arbitrary command. # # method The name of the method # arglist Delegation options proc ::snit::Comp.DelegatedTypemethod {method arglist} { variable compile variable typemethodInfo set errRoot "Error in \"delegate typemethod [list $method]...\"" # Next, parse the delegation options. set component "" set target "" set exceptions {} set pattern "" set methodTail [lindex $method end] foreach {opt value} $arglist { switch -exact $opt { to { set component $value } as { set target $value } except { set exceptions $value } using { set pattern $value } default { error "$errRoot, unknown delegation option \"$opt\"" } } } if {$component eq "" && $pattern eq ""} { error "$errRoot, missing \"to\"" } if {$methodTail eq "*" && $target ne ""} { error "$errRoot, cannot specify \"as\" with \"*\"" } if {$methodTail ne "*" && $exceptions ne ""} { error "$errRoot, can only specify \"except\" with \"*\"" } if {$pattern ne "" && $target ne ""} { error "$errRoot, cannot specify both \"as\" and \"using\"" } foreach token [lrange $method 1 end-1] { if {$token eq "*"} { error "$errRoot, \"*\" must be the last token." } } # NEXT, define the component if {$component ne ""} { Comp.DefineTypecomponent $component $errRoot } # NEXT, define the pattern. if {$pattern eq ""} { if {$methodTail eq "*"} { set pattern "%c %m" } elseif {$target ne ""} { set pattern "%c $target" } else { set pattern "%c %m" } } # Make sure the pattern is a valid list. if {[catch {lindex $pattern 0} result]} { error "$errRoot, the using pattern, \"$pattern\", is not a valid list" } # NEXT, check the method name against previously defined # methods. Comp.CheckMethodName $method 1 ::snit::typemethodInfo $errRoot set typemethodInfo($method) [list 0 $pattern $component] if {[string equal $methodTail "*"]} { Mappend compile(defs) { set %TYPE%::Snit_info(excepttypemethods) %EXCEPT% } %EXCEPT% [list $exceptions] } } # Creates a delegated method delegating it to a particular # component or command. # # method The name of the method # arglist Delegation options. proc ::snit::Comp.DelegatedMethod {method arglist} { variable compile variable methodInfo set errRoot "Error in \"delegate method [list $method]...\"" # Next, parse the delegation options. set component "" set target "" set exceptions {} set pattern "" set methodTail [lindex $method end] foreach {opt value} $arglist { switch -exact $opt { to { set component $value } as { set target $value } except { set exceptions $value } using { set pattern $value } default { error "$errRoot, unknown delegation option \"$opt\"" } } } if {$component eq "" && $pattern eq ""} { error "$errRoot, missing \"to\"" } if {$methodTail eq "*" && $target ne ""} { error "$errRoot, cannot specify \"as\" with \"*\"" } if {$methodTail ne "*" && $exceptions ne ""} { error "$errRoot, can only specify \"except\" with \"*\"" } if {$pattern ne "" && $target ne ""} { error "$errRoot, cannot specify both \"as\" and \"using\"" } foreach token [lrange $method 1 end-1] { if {$token eq "*"} { error "$errRoot, \"*\" must be the last token." } } # NEXT, we delegate some methods set compile(delegatesmethods) yes # NEXT, define the component. Allow typecomponents. if {$component ne ""} { if {[lsearch -exact $compile(typecomponents) $component] == -1} { Comp.DefineComponent $component $errRoot } } # NEXT, define the pattern. if {$pattern eq ""} { if {$methodTail eq "*"} { set pattern "%c %m" } elseif {$target ne ""} { set pattern "%c $target" } else { set pattern "%c %m" } } # Make sure the pattern is a valid list. if {[catch {lindex $pattern 0} result]} { error "$errRoot, the using pattern, \"$pattern\", is not a valid list" } # NEXT, check the method name against previously defined # methods. Comp.CheckMethodName $method 1 ::snit::methodInfo $errRoot # NEXT, save the method info. set methodInfo($method) [list 0 $pattern $component] if {[string equal $methodTail "*"]} { Mappend compile(defs) { set %TYPE%::Snit_info(exceptmethods) %EXCEPT% } %EXCEPT% [list $exceptions] } } # Creates a delegated option, delegating it to a particular # component and, optionally, to a particular option of that # component. # # optionDef The option definition # args definition arguments. proc ::snit::Comp.DelegatedOption {optionDef arglist} { variable compile # First, get the three option names. set option [lindex $optionDef 0] set resourceName [lindex $optionDef 1] set className [lindex $optionDef 2] set errRoot "Error in \"delegate option [list $optionDef]...\"" # Next, parse the delegation options. set component "" set target "" set exceptions {} foreach {opt value} $arglist { switch -exact $opt { to { set component $value } as { set target $value } except { set exceptions $value } default { error "$errRoot, unknown delegation option \"$opt\"" } } } if {$component eq ""} { error "$errRoot, missing \"to\"" } if {$option eq "*" && $target ne ""} { error "$errRoot, cannot specify \"as\" with \"delegate option *\"" } if {$option ne "*" && $exceptions ne ""} { error "$errRoot, can only specify \"except\" with \"delegate option *\"" } # Next, validate the option name if {"*" != $option} { if {![Comp.OptionNameIsValid $option]} { error "$errRoot, badly named option \"$option\"" } } if {$option in $compile(localoptions)} { error "$errRoot, \"$option\" has been defined locally" } if {$option in $compile(delegatedoptions)} { error "$errRoot, \"$option\" is multiply delegated" } # NEXT, define the component Comp.DefineComponent $component $errRoot # Next, define the target option, if not specified. if {![string equal $option "*"] && [string equal $target ""]} { set target $option } # NEXT, save the delegation data. set compile(hasoptions) yes if {![string equal $option "*"]} { lappend compile(delegatedoptions) $option # Next, compute the resource and class names, if they aren't # already defined. if {"" == $resourceName} { set resourceName [string range $option 1 end] } if {"" == $className} { set className [Capitalize $resourceName] } Mappend compile(defs) { set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 0 set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RES% set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS% lappend %TYPE%::Snit_optionInfo(delegated) %OPTION% set %TYPE%::Snit_optionInfo(target-%OPTION%) [list %COMP% %TARGET%] lappend %TYPE%::Snit_optionInfo(delegated-%COMP%) %OPTION% } %OPTION% $option \ %COMP% $component \ %TARGET% $target \ %RES% $resourceName \ %CLASS% $className } else { Mappend compile(defs) { set %TYPE%::Snit_optionInfo(starcomp) %COMP% set %TYPE%::Snit_optionInfo(except) %EXCEPT% } %COMP% $component %EXCEPT% [list $exceptions] } } # Exposes a component, effectively making the component's command an # instance method. # # component The logical name of the delegate # "as" sugar; if not "", must be "as" # methodname The desired method name for the component's command, or "" proc ::snit::Comp.statement.expose {component {"as" ""} {methodname ""}} { variable compile # FIRST, define the component Comp.DefineComponent $component # NEXT, define the method just as though it were in the type # definition. if {[string equal $methodname ""]} { set methodname $component } Comp.statement.method $methodname args [Expand { if {[llength $args] == 0} { return $%COMPONENT% } if {[string equal $%COMPONENT% ""]} { error "undefined component \"%COMPONENT%\"" } set cmd [linsert $args 0 $%COMPONENT%] return [uplevel 1 $cmd] } %COMPONENT% $component] } #----------------------------------------------------------------------- # Public commands # Compile a type definition, and return the results as a list of two # items: the fully-qualified type name, and a script that will define # the type when executed. # # which type, widget, or widgetadaptor # type the type name # body the type definition proc ::snit::compile {which type body} { return [Comp.Compile $which $type $body] } proc ::snit::type {type body} { return [Comp.Define [Comp.Compile type $type $body]] } proc ::snit::widget {type body} { return [Comp.Define [Comp.Compile widget $type $body]] } proc ::snit::widgetadaptor {type body} { return [Comp.Define [Comp.Compile widgetadaptor $type $body]] } proc ::snit::typemethod {type method arglist body} { # Make sure the type exists. if {![info exists ::${type}::Snit_info]} { error "no such type: \"$type\"" } upvar ::${type}::Snit_info Snit_info upvar ::${type}::Snit_typemethodInfo Snit_typemethodInfo # FIRST, check the typemethod name against previously defined # typemethods. Comp.CheckMethodName $method 0 ::${type}::Snit_typemethodInfo \ "Cannot define \"$method\"" # NEXT, check the arguments CheckArgs "snit::typemethod $type $method" $arglist # Next, add magic reference to type. set arglist [concat type $arglist] # Next, add typevariable declarations to body: set body "$Snit_info(tvardecs)\n$body" # Next, define it. if {[llength $method] == 1} { set Snit_typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""} uplevel 1 [list proc ${type}::Snit_typemethod$method $arglist $body] } else { set Snit_typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""} set suffix [join $method _] uplevel 1 [list proc ${type}::Snit_htypemethod$suffix $arglist $body] } } proc ::snit::method {type method arglist body} { # Make sure the type exists. if {![info exists ::${type}::Snit_info]} { error "no such type: \"$type\"" } upvar ::${type}::Snit_methodInfo Snit_methodInfo upvar ::${type}::Snit_info Snit_info # FIRST, check the method name against previously defined # methods. Comp.CheckMethodName $method 0 ::${type}::Snit_methodInfo \ "Cannot define \"$method\"" # NEXT, check the arguments CheckArgs "snit::method $type $method" $arglist # Next, add magic references to type and self. set arglist [concat type selfns win self $arglist] # Next, add variable declarations to body: set body "$Snit_info(tvardecs)\n$Snit_info(ivardecs)\n$body" # Next, define it. if {[llength $method] == 1} { set Snit_methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""} uplevel 1 [list proc ${type}::Snit_method$method $arglist $body] } else { set Snit_methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""} set suffix [join $method _] uplevel 1 [list proc ${type}::Snit_hmethod$suffix $arglist $body] } } # Defines a proc within the compiler; this proc can call other # type definition statements, and thus can be used for meta-programming. proc ::snit::macro {name arglist body} { variable compiler variable reservedwords # FIRST, make sure the compiler is defined. Comp.Init # NEXT, check the macro name against the reserved words if {[lsearch -exact $reservedwords $name] != -1} { error "invalid macro name \"$name\"" } # NEXT, see if the name has a namespace; if it does, define the # namespace. set ns [namespace qualifiers $name] if {$ns ne ""} { $compiler eval "namespace eval $ns {}" } # NEXT, define the macro $compiler eval [list _proc $name $arglist $body] } #----------------------------------------------------------------------- # Utility Functions # # These are utility functions used while compiling Snit types. # Builds a template from a tagged list of text blocks, then substitutes # all symbols in the mapTable, returning the expanded template. proc ::snit::Expand {template args} { return [string map $args $template] } # Expands a template and appends it to a variable. proc ::snit::Mappend {varname template args} { upvar $varname myvar append myvar [string map $args $template] } # Checks argument list against reserved args proc ::snit::CheckArgs {which arglist} { variable reservedArgs foreach name $reservedArgs { if {$name in $arglist} { error "$which's arglist may not contain \"$name\" explicitly" } } } # Capitalizes the first letter of a string. proc ::snit::Capitalize {text} { return [string toupper $text 0] } #======================================================================= # Snit Runtime Library # # These are procs used by Snit types and widgets at runtime. #----------------------------------------------------------------------- # Object Creation # Creates a new instance of the snit::type given its name and the args. # # type The snit::type # name The instance name # args Args to pass to the constructor proc ::snit::RT.type.typemethod.create {type name args} { variable ${type}::Snit_info variable ${type}::Snit_optionInfo # FIRST, qualify the name. if {![string match "::*" $name]} { # Get caller's namespace; # append :: if not global namespace. set ns [uplevel 1 [list namespace current]] if {"::" != $ns} { append ns "::" } set name "$ns$name" } # NEXT, if %AUTO% appears in the name, generate a unique # command name. Otherwise, ensure that the name isn't in use. if {[string match "*%AUTO%*" $name]} { set name [::snit::RT.UniqueName Snit_info(counter) $type $name] } elseif {!$Snit_info(canreplace) && [llength [info commands $name]]} { error "command \"$name\" already exists" } # NEXT, create the instance's namespace. set selfns \ [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type] namespace eval $selfns {} # NEXT, install the dispatcher RT.MakeInstanceCommand $type $selfns $name # Initialize the options to their defaults. namespace upvar ${selfns} options options foreach opt $Snit_optionInfo(local) { set options($opt) $Snit_optionInfo(default-$opt) } # Initialize the instance vars to their defaults. # selfns must be defined, as it is used implicitly. ${type}::Snit_instanceVars $selfns # Execute the type's constructor. set errcode [catch { RT.ConstructInstance $type $selfns $name $args } result] if {$errcode} { global errorInfo global errorCode set theInfo $errorInfo set theCode $errorCode ::snit::RT.DestroyObject $type $selfns $name error "Error in constructor: $result" $theInfo $theCode } # NEXT, return the object's name. return $name } # Creates a new instance of the snit::widget or snit::widgetadaptor # given its name and the args. # # type The snit::widget or snit::widgetadaptor # name The instance name # args Args to pass to the constructor proc ::snit::RT.widget.typemethod.create {type name args} { variable ${type}::Snit_info variable ${type}::Snit_optionInfo # FIRST, if %AUTO% appears in the name, generate a unique # command name. if {[string match "*%AUTO%*" $name]} { set name [::snit::RT.UniqueName Snit_info(counter) $type $name] } # NEXT, create the instance's namespace. set selfns \ [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type] namespace eval $selfns { } # NEXT, Initialize the widget's own options to their defaults. namespace upvar $selfns options options foreach opt $Snit_optionInfo(local) { set options($opt) $Snit_optionInfo(default-$opt) } # Initialize the instance vars to their defaults. ${type}::Snit_instanceVars $selfns # NEXT, if this is a normal widget (not a widget adaptor) then create a # frame as its hull. We set the frame's -class to the user's widgetclass, # or, if none, search for -class in the args list, otherwise default to # the basename of the $type with an initial upper case letter. if {!$Snit_info(isWidgetAdaptor)} { # FIRST, determine the class name set wclass $Snit_info(widgetclass) if {$Snit_info(widgetclass) eq ""} { set idx [lsearch -exact $args -class] if {$idx >= 0 && ($idx%2 == 0)} { # -class exists and is in the -option position set wclass [lindex $args [expr {$idx+1}]] set args [lreplace $args $idx [expr {$idx+1}]] } else { set wclass [::snit::Capitalize [namespace tail $type]] } } # NEXT, create the widget set self $name package require Tk ${type}::installhull using $Snit_info(hulltype) -class $wclass # NEXT, let's query the option database for our # widget, now that we know that it exists. foreach opt $Snit_optionInfo(local) { set dbval [RT.OptionDbGet $type $name $opt] if {"" != $dbval} { set options($opt) $dbval } } } # Execute the type's constructor, and verify that it # has a hull. set errcode [catch { RT.ConstructInstance $type $selfns $name $args ::snit::RT.Component $type $selfns hull # Prepare to call the object's destructor when the # event is received. Use a Snit-specific bindtag # so that the widget name's tag is unencumbered. bind Snit$type$name [::snit::Expand { ::snit::RT.DestroyObject %TYPE% %NS% %W } %TYPE% $type %NS% $selfns] # Insert the bindtag into the list of bindtags right # after the widget name. set taglist [bindtags $name] set ndx [lsearch -exact $taglist $name] incr ndx bindtags $name [linsert $taglist $ndx Snit$type$name] } result] if {$errcode} { global errorInfo global errorCode set theInfo $errorInfo set theCode $errorCode ::snit::RT.DestroyObject $type $selfns $name error "Error in constructor: $result" $theInfo $theCode } # NEXT, return the object's name. return $name } # RT.MakeInstanceCommand type selfns instance # # type The object type # selfns The instance namespace # instance The instance name # # Creates the instance proc. proc ::snit::RT.MakeInstanceCommand {type selfns instance} { variable ${type}::Snit_info # FIRST, remember the instance name. The Snit_instance variable # allows the instance to figure out its current name given the # instance namespace. namespace upvar $selfns Snit_instance Snit_instance set Snit_instance $instance # NEXT, qualify the proc name if it's a widget. if {$Snit_info(isWidget)} { set procname ::$instance } else { set procname $instance } # NEXT, install the new proc # WHD: Snit 2.0 code set unknownCmd [list ::snit::RT.UnknownMethod $type $selfns $instance ""] set createCmd [list namespace ensemble create \ -command $procname \ -unknown $unknownCmd \ -prefixes 0] namespace eval $selfns $createCmd # NEXT, add the trace. trace add command $procname {rename delete} \ [list ::snit::RT.InstanceTrace $type $selfns $instance] } # This proc is called when the instance command is renamed. # If op is delete, then new will always be "", so op is redundant. # # type The fully-qualified type name # selfns The instance namespace # win The original instance/tk window name. # old old instance command name # new new instance command name # op rename or delete # # If the op is delete, we need to clean up the object; otherwise, # we need to track the change. # # NOTE: In Tcl 8.4.2 there's a bug: errors in rename and delete # traces aren't propagated correctly. Instead, they silently # vanish. Add a catch to output any error message. proc ::snit::RT.InstanceTrace {type selfns win old new op} { variable ${type}::Snit_info # Note to developers ... # For Tcl 8.4.0, errors thrown in trace handlers vanish silently. # Therefore we catch them here and create some output to help in # debugging such problems. if {[catch { # FIRST, clean up if necessary if {"" == $new} { if {$Snit_info(isWidget)} { destroy $win } else { ::snit::RT.DestroyObject $type $selfns $win } } else { # Otherwise, track the change. variable ${selfns}::Snit_instance set Snit_instance [uplevel 1 [list namespace which -command $new]] # Also, clear the instance caches, as many cached commands # might be invalid. RT.ClearInstanceCaches $selfns } } result]} { global errorInfo # Pop up the console on Windows wish, to enable stdout. # This clobbers errorInfo on unix, so save it so we can print it. set ei $errorInfo catch {console show} puts "Error in ::snit::RT.InstanceTrace $type $selfns $win $old $new $op:" puts $ei } } # Calls the instance constructor and handles related housekeeping. proc ::snit::RT.ConstructInstance {type selfns instance arglist} { variable ${type}::Snit_optionInfo variable ${selfns}::Snit_iinfo # Track whether we are constructed or not. set Snit_iinfo(constructed) 0 # Call the user's constructor eval [linsert $arglist 0 \ ${type}::Snit_constructor $type $selfns $instance $instance] set Snit_iinfo(constructed) 1 # Validate the initial set of options (including defaults) foreach option $Snit_optionInfo(local) { set value [set ${selfns}::options($option)] if {$Snit_optionInfo(typespec-$option) ne ""} { if {[catch { $Snit_optionInfo(typeobj-$option) validate $value } result]} { return -code error "invalid $option default: $result" } } } # Unset the configure cache for all -readonly options. # This ensures that the next time anyone tries to # configure it, an error is thrown. foreach opt $Snit_optionInfo(local) { if {$Snit_optionInfo(readonly-$opt)} { unset -nocomplain ${selfns}::Snit_configureCache($opt) } } return } # Returns a unique command name. # # REQUIRE: type is a fully qualified name. # REQUIRE: name contains "%AUTO%" # PROMISE: the returned command name is unused. proc ::snit::RT.UniqueName {countervar type name} { upvar $countervar counter while 1 { # FIRST, bump the counter and define the %AUTO% instance name; # then substitute it into the specified name. Wrap around at # 2^31 - 2 to prevent overflow problems. incr counter if {$counter > 2147483646} { set counter 0 } set auto "[namespace tail $type]$counter" set candidate [Expand $name %AUTO% $auto] if {![llength [info commands $candidate]]} { return $candidate } } } # Returns a unique instance namespace, fully qualified. # # countervar The name of a counter variable # type The instance's type # # REQUIRE: type is fully qualified # PROMISE: The returned namespace name is unused. proc ::snit::RT.UniqueInstanceNamespace {countervar type} { upvar $countervar counter while 1 { # FIRST, bump the counter and define the namespace name. # Then see if it already exists. Wrap around at # 2^31 - 2 to prevent overflow problems. incr counter if {$counter > 2147483646} { set counter 0 } set ins "${type}::Snit_inst${counter}" if {![namespace exists $ins]} { return $ins } } } # Retrieves an option's value from the option database. # Returns "" if no value is found. proc ::snit::RT.OptionDbGet {type self opt} { variable ${type}::Snit_optionInfo return [option get $self \ $Snit_optionInfo(resource-$opt) \ $Snit_optionInfo(class-$opt)] } #----------------------------------------------------------------------- # Object Destruction # Implements the standard "destroy" method # # type The snit type # selfns The instance's instance namespace # win The instance's original name # self The instance's current name proc ::snit::RT.method.destroy {type selfns win self} { variable ${selfns}::Snit_iinfo # Can't destroy the object if it isn't complete constructed. if {!$Snit_iinfo(constructed)} { return -code error "Called 'destroy' method in constructor" } # Calls Snit_cleanup, which (among other things) calls the # user's destructor. ::snit::RT.DestroyObject $type $selfns $win } # This is the function that really cleans up; it's automatically # called when any instance is destroyed, e.g., by "$object destroy" # for types, and by the event for widgets. # # type The fully-qualified type name. # selfns The instance namespace # win The original instance command name. proc ::snit::RT.DestroyObject {type selfns win} { variable ${type}::Snit_info # If the variable Snit_instance doesn't exist then there's no # instance command for this object -- it's most likely a # widgetadaptor. Consequently, there are some things that # we don't need to do. if {[info exists ${selfns}::Snit_instance]} { namespace upvar $selfns Snit_instance instance # First, remove the trace on the instance name, so that we # don't call RT.DestroyObject recursively. RT.RemoveInstanceTrace $type $selfns $win $instance # Next, call the user's destructor ${type}::Snit_destructor $type $selfns $win $instance # Next, if this isn't a widget, delete the instance command. # If it is a widget, get the hull component's name, and rename # it back to the widget name # Next, delete the hull component's instance command, # if there is one. if {$Snit_info(isWidget)} { set hullcmd [::snit::RT.Component $type $selfns hull] catch {rename $instance ""} # Clear the bind event bind Snit$type$win "" if {[llength [info commands $hullcmd]]} { # FIRST, rename the hull back to its original name. # If the hull is itself a megawidget, it will have its # own cleanup to do, and it might not do it properly # if it doesn't have the right name. rename $hullcmd ::$instance # NEXT, destroy it. destroy $instance } } else { catch {rename $instance ""} } } # Next, delete the instance's namespace. This kills any # instance variables. namespace delete $selfns return } # Remove instance trace # # type The fully qualified type name # selfns The instance namespace # win The original instance name/Tk window name # instance The current instance name proc ::snit::RT.RemoveInstanceTrace {type selfns win instance} { variable ${type}::Snit_info if {$Snit_info(isWidget)} { set procname ::$instance } else { set procname $instance } # NEXT, remove any trace on this name catch { trace remove command $procname {rename delete} \ [list ::snit::RT.InstanceTrace $type $selfns $win] } } #----------------------------------------------------------------------- # Typecomponent Management and Method Caching # Typecomponent trace; used for write trace on typecomponent # variables. Saves the new component object name, provided # that certain conditions are met. Also clears the typemethod # cache. proc ::snit::RT.TypecomponentTrace {type component n1 n2 op} { namespace upvar $type \ Snit_info Snit_info \ $component cvar \ Snit_typecomponents Snit_typecomponents # Save the new component value. set Snit_typecomponents($component) $cvar # Clear the typemethod cache. # TBD: can we unset just the elements related to # this component? # WHD: Namespace 2.0 code namespace ensemble configure $type -map {} } # WHD: Snit 2.0 code # # RT.UnknownTypemethod type eId eCmd method args # # type The type # eId The ensemble command ID; "" for the instance itself. # eCmd The ensemble command name. # method The unknown method name. # args The additional arguments, if any. # # This proc looks up the method relative to the specified ensemble. # If no method is found, it assumes that the "create" method is # desired, and that the "method" is the instance name. In this case, # it returns the "create" typemethod command with the instance name # appended; this will cause the instance to be created without updating # the -map. If the method is found, the method's command is created and # added to the -map; the function returns the empty list. proc snit::RT.UnknownTypemethod {type eId eCmd method args} { namespace upvar $type \ Snit_typemethodInfo Snit_typemethodInfo \ Snit_typecomponents Snit_typecomponents \ Snit_info Snit_info # FIRST, get the pattern data and the typecomponent name. set implicitCreate 0 set instanceName "" set fullMethod $eId lappend fullMethod $method set starredMethod [concat $eId *] set methodTail $method if {[info exists Snit_typemethodInfo($fullMethod)]} { set key $fullMethod } elseif {[info exists Snit_typemethodInfo($starredMethod)]} { if {[lsearch -exact $Snit_info(excepttypemethods) $methodTail] == -1} { set key $starredMethod } else { # WHD: The method is explicitly not delegated, so this is an error. # Or should we treat it as an instance name? return [list ] } } elseif {[llength $fullMethod] > 1} { return [list ] } elseif {$Snit_info(hasinstances)} { # Assume the unknown name is an instance name to create, unless # this is a widget and the style of the name is wrong, or the # name mimics a standard typemethod. if {[set ${type}::Snit_info(isWidget)] && ![string match ".*" $method]} { return [list ] } # Without this check, the call "$type info" will redefine the # standard "::info" command, with disastrous results. Since it's # a likely thing to do if !-typeinfo, put in an explicit check. if {$method eq "info" || $method eq "destroy"} { return [list ] } set implicitCreate 1 set instanceName $method set key create set method create } else { return [list ] } foreach {flag pattern compName} $Snit_typemethodInfo($key) {} if {$flag == 1} { # FIRST, define the ensemble command. lappend eId $method set newCmd ${type}::Snit_ten[llength $eId]_[join $eId _] set unknownCmd [list ::snit::RT.UnknownTypemethod \ $type $eId] set createCmd [list namespace ensemble create \ -command $newCmd \ -unknown $unknownCmd \ -prefixes 0] namespace eval $type $createCmd # NEXT, add the method to the current ensemble set map [namespace ensemble configure $eCmd -map] dict append map $method $newCmd namespace ensemble configure $eCmd -map $map return [list ] } # NEXT, build the substitution list set subList [list \ %% % \ %t $type \ %M $fullMethod \ %m [lindex $fullMethod end] \ %j [join $fullMethod _]] if {$compName ne ""} { if {![info exists Snit_typecomponents($compName)]} { error "$type delegates typemethod \"$method\" to undefined typecomponent \"$compName\"" } lappend subList %c [list $Snit_typecomponents($compName)] } set command {} foreach subpattern $pattern { lappend command [string map $subList $subpattern] } if {$implicitCreate} { # In this case, $method is the name of the instance to # create. Don't cache, as we usually won't do this one # again. lappend command $instanceName return $command } # NEXT, if the actual command name isn't fully qualified, # assume it's global. set cmd [lindex $command 0] if {[string index $cmd 0] ne ":"} { set command [lreplace $command 0 0 "::$cmd"] } # NEXT, update the ensemble map. set map [namespace ensemble configure $eCmd -map] dict append map $method $command namespace ensemble configure $eCmd -map $map return [list ] } #----------------------------------------------------------------------- # Component Management and Method Caching # Retrieves the object name given the component name. proc ::snit::RT.Component {type selfns name} { variable ${selfns}::Snit_components if {[catch {set Snit_components($name)} result]} { variable ${selfns}::Snit_instance error "component \"$name\" is undefined in $type $Snit_instance" } return $result } # Component trace; used for write trace on component instance # variables. Saves the new component object name, provided # that certain conditions are met. Also clears the method # cache. proc ::snit::RT.ComponentTrace {type selfns component n1 n2 op} { namespace upvar $type Snit_info Snit_info namespace upvar $selfns \ $component cvar \ Snit_components Snit_components # If they try to redefine the hull component after # it's been defined, that's an error--but only if # this is a widget or widget adaptor. if {"hull" == $component && $Snit_info(isWidget) && [info exists Snit_components($component)]} { set cvar $Snit_components($component) error "The hull component cannot be redefined" } # Save the new component value. set Snit_components($component) $cvar # Clear the instance caches. # TBD: can we unset just the elements related to # this component? RT.ClearInstanceCaches $selfns } # WHD: Snit 2.0 code # # RT.UnknownMethod type selfns win eId eCmd method args # # type The type or widget command. # selfns The instance namespace. # win The original instance name. # eId The ensemble command ID; "" for the instance itself. # eCmd The real ensemble command name # method The unknown method name # args The additional arguments, if any. # # This proc looks up the method relative to the specific ensemble. # If no method is found, it returns an empty list; this will result in # the parent ensemble throwing an error. # If the method is found, the ensemble's -map is extended with the # correct command, and the empty list is returned; this caches the # method's command. If the method is found, and it is also an # ensemble, the ensemble command is created with an empty map. proc ::snit::RT.UnknownMethod {type selfns win eId eCmd method args} { variable ${type}::Snit_info variable ${type}::Snit_methodInfo variable ${type}::Snit_typecomponents variable ${selfns}::Snit_components # FIRST, get the "self" value set self [set ${selfns}::Snit_instance] # FIRST, get the pattern data and the component name. set fullMethod $eId lappend fullMethod $method set starredMethod [concat $eId *] set methodTail $method if {[info exists Snit_methodInfo($fullMethod)]} { set key $fullMethod } elseif {[info exists Snit_methodInfo($starredMethod)] && [lsearch -exact $Snit_info(exceptmethods) $methodTail] == -1} { set key $starredMethod } else { return [list ] } foreach {flag pattern compName} $Snit_methodInfo($key) {} if {$flag == 1} { # FIRST, define the ensemble command. lappend eId $method # Fix provided by Anton Kovalenko; previously this call erroneously # used ${type} rather than ${selfns}. set newCmd ${selfns}::Snit_en[llength $eId]_[join $eId _] set unknownCmd [list ::snit::RT.UnknownMethod \ $type $selfns $win $eId] set createCmd [list namespace ensemble create \ -command $newCmd \ -unknown $unknownCmd \ -prefixes 0] namespace eval $selfns $createCmd # NEXT, add the method to the current ensemble set map [namespace ensemble configure $eCmd -map] dict append map $method $newCmd namespace ensemble configure $eCmd -map $map return [list ] } # NEXT, build the substitution list set subList [list \ %% % \ %t $type \ %M $fullMethod \ %m [lindex $fullMethod end] \ %j [join $fullMethod _] \ %n [list $selfns] \ %w [list $win] \ %s [list $self]] if {$compName ne ""} { if {[info exists Snit_components($compName)]} { set compCmd $Snit_components($compName) } elseif {[info exists Snit_typecomponents($compName)]} { set compCmd $Snit_typecomponents($compName) } else { error "$type $self delegates method \"$fullMethod\" to undefined component \"$compName\"" } lappend subList %c [list $compCmd] } # Note: The cached command will execute faster if it's # already a list. set command {} foreach subpattern $pattern { lappend command [string map $subList $subpattern] } # NEXT, if the actual command name isn't fully qualified, # assume it's global. set cmd [lindex $command 0] if {[string index $cmd 0] ne ":"} { set command [lreplace $command 0 0 "::$cmd"] } # NEXT, update the ensemble map. set map [namespace ensemble configure $eCmd -map] dict append map $method $command namespace ensemble configure $eCmd -map $map return [list ] } # Clears all instance command caches proc ::snit::RT.ClearInstanceCaches {selfns} { # WHD: clear ensemble -map if {![info exists ${selfns}::Snit_instance]} { # Component variable set prior to constructor # via the "variable" type definition statement. return } set self [set ${selfns}::Snit_instance] namespace ensemble configure $self -map {} unset -nocomplain -- ${selfns}::Snit_cgetCache unset -nocomplain -- ${selfns}::Snit_configureCache unset -nocomplain -- ${selfns}::Snit_validateCache } #----------------------------------------------------------------------- # Component Installation # Implements %TYPE%::installhull. The variables self and selfns # must be defined in the caller's context. # # Installs the named widget as the hull of a # widgetadaptor. Once the widget is hijacked, its new name # is assigned to the hull component. proc ::snit::RT.installhull {type {using "using"} {widgetType ""} args} { variable ${type}::Snit_info variable ${type}::Snit_optionInfo upvar 1 self self upvar 1 selfns selfns namespace upvar $selfns \ hull hull \ options options # FIRST, make sure we can do it. if {!$Snit_info(isWidget)} { error "installhull is valid only for snit::widgetadaptors" } if {[info exists ${selfns}::Snit_instance]} { error "hull already installed for $type $self" } # NEXT, has it been created yet? If not, create it using # the specified arguments. if {"using" == $using} { # FIRST, create the widget set cmd [linsert $args 0 $widgetType $self] set obj [uplevel 1 $cmd] # NEXT, for each option explicitly delegated to the hull # that doesn't appear in the usedOpts list, get the # option database value and apply it--provided that the # real option name and the target option name are different. # (If they are the same, then the option database was # already queried as part of the normal widget creation.) # # Also, we don't need to worry about implicitly delegated # options, as the option and target option names must be # the same. if {[info exists Snit_optionInfo(delegated-hull)]} { # FIRST, extract all option names from args set usedOpts {} set ndx [lsearch -glob $args "-*"] foreach {opt val} [lrange $args $ndx end] { lappend usedOpts $opt } foreach opt $Snit_optionInfo(delegated-hull) { set target [lindex $Snit_optionInfo(target-$opt) 1] if {"$target" == $opt} { continue } set result [lsearch -exact $usedOpts $target] if {$result != -1} { continue } set dbval [RT.OptionDbGet $type $self $opt] $obj configure $target $dbval } } } else { set obj $using if {$obj ne $self} { error \ "hull name mismatch: \"$obj\" != \"$self\"" } } # NEXT, get the local option defaults. foreach opt $Snit_optionInfo(local) { set dbval [RT.OptionDbGet $type $self $opt] if {"" != $dbval} { set options($opt) $dbval } } # NEXT, do the magic set i 0 while 1 { incr i set newName "::hull${i}$self" if {![llength [info commands $newName]]} { break } } rename ::$self $newName RT.MakeInstanceCommand $type $selfns $self # Note: this relies on RT.ComponentTrace to do the dirty work. set hull $newName return } # Implements %TYPE%::install. # # Creates a widget and installs it as the named component. # It expects self and selfns to be defined in the caller's context. proc ::snit::RT.install {type compName "using" widgetType winPath args} { variable ${type}::Snit_optionInfo variable ${type}::Snit_info upvar 1 self self upvar 1 selfns selfns namespace upvar ${selfns} \ $compName comp \ hull hull # We do the magic option database stuff only if $self is # a widget. if {$Snit_info(isWidget)} { if {"" == $hull} { error "tried to install \"$compName\" before the hull exists" } # FIRST, query the option database and save the results # into args. Insert them before the first option in the # list, in case there are any non-standard parameters. # # Note: there might not be any delegated options; if so, # don't bother. if {[info exists Snit_optionInfo(delegated-$compName)]} { set ndx [lsearch -glob $args "-*"] foreach opt $Snit_optionInfo(delegated-$compName) { set dbval [RT.OptionDbGet $type $self $opt] if {"" != $dbval} { set target [lindex $Snit_optionInfo(target-$opt) 1] set args [linsert $args $ndx $target $dbval] } } } } # NEXT, create the component and save it. set cmd [concat [list $widgetType $winPath] $args] set comp [uplevel 1 $cmd] # NEXT, handle the option database for "delegate option *", # in widgets only. if {$Snit_info(isWidget) && $Snit_optionInfo(starcomp) eq $compName} { # FIRST, get the list of option specs from the widget. # If configure doesn't work, skip it. if {[catch {$comp configure} specs]} { return } # NEXT, get the set of explicitly used options from args set usedOpts {} set ndx [lsearch -glob $args "-*"] foreach {opt val} [lrange $args $ndx end] { lappend usedOpts $opt } # NEXT, "delegate option *" matches all options defined # by this widget that aren't defined by the widget as a whole, # and that aren't excepted. Plus, we skip usedOpts. So build # a list of the options it can't match. set skiplist [concat \ $usedOpts \ $Snit_optionInfo(except) \ $Snit_optionInfo(local) \ $Snit_optionInfo(delegated)] # NEXT, loop over all of the component's options, and set # any not in the skip list for which there is an option # database value. foreach spec $specs { # Skip aliases if {[llength $spec] != 5} { continue } set opt [lindex $spec 0] if {[lsearch -exact $skiplist $opt] != -1} { continue } set res [lindex $spec 1] set cls [lindex $spec 2] set dbvalue [option get $self $res $cls] if {"" != $dbvalue} { $comp configure $opt $dbvalue } } } return } #----------------------------------------------------------------------- # Method/Variable Name Qualification # Implements %TYPE%::variable. Requires selfns. proc ::snit::RT.variable {varname} { upvar 1 selfns selfns if {![string match "::*" $varname]} { uplevel 1 [list upvar 1 ${selfns}::$varname $varname] } else { # varname is fully qualified; let the standard # "variable" command handle it. uplevel 1 [list ::variable $varname] } } # Fully qualifies a typevariable name. # # This is used to implement the mytypevar command. proc ::snit::RT.mytypevar {type name} { return ${type}::$name } # Fully qualifies an instance variable name. # # This is used to implement the myvar command. proc ::snit::RT.myvar {name} { upvar 1 selfns selfns return ${selfns}::$name } # Use this like "list" to convert a proc call into a command # string to pass to another object (e.g., as a -command). # Qualifies the proc name properly. # # This is used to implement the "myproc" command. proc ::snit::RT.myproc {type procname args} { set procname "${type}::$procname" return [linsert $args 0 $procname] } # DEPRECATED proc ::snit::RT.codename {type name} { return "${type}::$name" } # Use this like "list" to convert a typemethod call into a command # string to pass to another object (e.g., as a -command). # Inserts the type command at the beginning. # # This is used to implement the "mytypemethod" command. proc ::snit::RT.mytypemethod {type args} { return [linsert $args 0 $type] } # Use this like "list" to convert a method call into a command # string to pass to another object (e.g., as a -command). # Inserts the code at the beginning to call the right object, even if # the object's name has changed. Requires that selfns be defined # in the calling context, eg. can only be called in instance # code. # # This is used to implement the "mymethod" command. proc ::snit::RT.mymethod {args} { upvar 1 selfns selfns return [linsert $args 0 ::snit::RT.CallInstance ${selfns}] } # Calls an instance method for an object given its # instance namespace and remaining arguments (the first of which # will be the method name. # # selfns The instance namespace # args The arguments # # Uses the selfns to determine $self, and calls the method # in the normal way. # # This is used to implement the "mymethod" command. proc ::snit::RT.CallInstance {selfns args} { namespace upvar $selfns Snit_instance self set retval [catch {uplevel 1 [linsert $args 0 $self]} result] if {$retval} { if {$retval == 1} { global errorInfo global errorCode return -code error -errorinfo $errorInfo \ -errorcode $errorCode $result } else { return -code $retval $result } } return $result } # Looks for the named option in the named variable. If found, # it and its value are removed from the list, and the value # is returned. Otherwise, the default value is returned. # If the option is undelegated, it's own default value will be # used if none is specified. # # Implements the "from" command. proc ::snit::RT.from {type argvName option {defvalue ""}} { namespace upvar $type Snit_optionInfo Snit_optionInfo upvar $argvName argv set ioption [lsearch -exact $argv $option] if {$ioption == -1} { if {"" == $defvalue && [info exists Snit_optionInfo(default-$option)]} { return $Snit_optionInfo(default-$option) } else { return $defvalue } } set ivalue [expr {$ioption + 1}] set value [lindex $argv $ivalue] set argv [lreplace $argv $ioption $ivalue] return $value } #----------------------------------------------------------------------- # Type Destruction # Implements the standard "destroy" typemethod: # Destroys a type completely. # # type The snit type proc ::snit::RT.typemethod.destroy {type} { variable ${type}::Snit_info # FIRST, destroy all instances foreach selfns [namespace children $type "${type}::Snit_inst*"] { if {![namespace exists $selfns]} { continue } namespace upvar $selfns Snit_instance obj if {$Snit_info(isWidget)} { destroy $obj } else { if {[llength [info commands $obj]]} { $obj destroy } } } # NEXT, get rid of the type command. rename $type "" # NEXT, destroy the type's data. namespace delete $type } #----------------------------------------------------------------------- # Option Handling # Implements the standard "cget" method # # type The snit type # selfns The instance's instance namespace # win The instance's original name # self The instance's current name # option The name of the option proc ::snit::RT.method.cget {type selfns win self option} { if {[catch {set ${selfns}::Snit_cgetCache($option)} command]} { set command [snit::RT.CacheCgetCommand $type $selfns $win $self $option] if {[llength $command] == 0} { return -code error "unknown option \"$option\"" } } uplevel 1 $command } # Retrieves and caches the command that implements "cget" for the # specified option. # # type The snit type # selfns The instance's instance namespace # win The instance's original name # self The instance's current name # option The name of the option proc ::snit::RT.CacheCgetCommand {type selfns win self option} { variable ${type}::Snit_optionInfo variable ${selfns}::Snit_cgetCache if {[info exists Snit_optionInfo(islocal-$option)]} { # We know the item; it's either local, or explicitly delegated. if {$Snit_optionInfo(islocal-$option)} { # It's a local option. If it has a cget method defined, # use it; otherwise just return the value. if {$Snit_optionInfo(cget-$option) eq ""} { set command [list set ${selfns}::options($option)] } else { # WHD: Snit 2.0 code -- simpler, no slower. set command [list \ $self \ {*}$Snit_optionInfo(cget-$option) \ $option] } set Snit_cgetCache($option) $command return $command } # Explicitly delegated option; get target set comp [lindex $Snit_optionInfo(target-$option) 0] set target [lindex $Snit_optionInfo(target-$option) 1] } elseif {$Snit_optionInfo(starcomp) ne "" && [lsearch -exact $Snit_optionInfo(except) $option] == -1} { # Unknown option, but unknowns are delegated; get target. set comp $Snit_optionInfo(starcomp) set target $option } else { return "" } # Get the component's object. set obj [RT.Component $type $selfns $comp] set command [list $obj cget $target] set Snit_cgetCache($option) $command return $command } # Implements the standard "configurelist" method # # type The snit type # selfns The instance's instance namespace # win The instance's original name # self The instance's current name # optionlist A list of options and their values. proc ::snit::RT.method.configurelist {type selfns win self optionlist} { variable ${type}::Snit_optionInfo foreach {option value} $optionlist { # FIRST, get the configure command, caching it if need be. if {[catch {set ${selfns}::Snit_configureCache($option)} command]} { set command [snit::RT.CacheConfigureCommand \ $type $selfns $win $self $option] if {[llength $command] == 0} { return -code error "unknown option \"$option\"" } } # NEXT, if we have a type-validation object, use it. # TBD: Should test (islocal-$option) here, but islocal # isn't defined for implicitly delegated options. if {[info exists Snit_optionInfo(typeobj-$option)] && $Snit_optionInfo(typeobj-$option) ne ""} { if {[catch { $Snit_optionInfo(typeobj-$option) validate $value } result]} { return -code error "invalid $option value: $result" } } # NEXT, the caching the configure command also cached the # validate command, if any. If we have one, run it. set valcommand [set ${selfns}::Snit_validateCache($option)] if {[llength $valcommand]} { lappend valcommand $value uplevel 1 $valcommand } # NEXT, configure the option with the value. lappend command $value uplevel 1 $command } return } # Retrieves and caches the command that stores the named option. # Also stores the command that validates the name option if any; # If none, the validate command is "", so that the cache is always # populated. # # type The snit type # selfns The instance's instance namespace # win The instance's original name # self The instance's current name # option An option name proc ::snit::RT.CacheConfigureCommand {type selfns win self option} { variable ${type}::Snit_optionInfo variable ${selfns}::Snit_configureCache variable ${selfns}::Snit_validateCache if {[info exist Snit_optionInfo(islocal-$option)]} { # We know the item; it's either local, or explicitly delegated. if {$Snit_optionInfo(islocal-$option)} { # It's a local option. # If it's readonly, it throws an error if we're already # constructed. if {$Snit_optionInfo(readonly-$option)} { if {[set ${selfns}::Snit_iinfo(constructed)]} { error "option $option can only be set at instance creation" } } # If it has a validate method, cache that for later. if {$Snit_optionInfo(validate-$option) ne ""} { # WHD: Snit 2.0 code -- simpler, no slower. set command [list \ $self \ {*}$Snit_optionInfo(validate-$option) \ $option] set Snit_validateCache($option) $command } else { set Snit_validateCache($option) "" } # If it has a configure method defined, # cache it; otherwise, just set the value. if {$Snit_optionInfo(configure-$option) eq ""} { set command [list set ${selfns}::options($option)] } else { # WHD: Snit 2.0 code -- simpler, no slower. set command [list \ $self \ {*}$Snit_optionInfo(configure-$option) \ $option] } set Snit_configureCache($option) $command return $command } # Delegated option: get target. set comp [lindex $Snit_optionInfo(target-$option) 0] set target [lindex $Snit_optionInfo(target-$option) 1] } elseif {$Snit_optionInfo(starcomp) != "" && [lsearch -exact $Snit_optionInfo(except) $option] == -1} { # Unknown option, but unknowns are delegated. set comp $Snit_optionInfo(starcomp) set target $option } else { return "" } # There is no validate command in this case; save an empty string. set Snit_validateCache($option) "" # Get the component's object set obj [RT.Component $type $selfns $comp] set command [list $obj configure $target] set Snit_configureCache($option) $command return $command } # Implements the standard "configure" method # # type The snit type # selfns The instance's instance namespace # win The instance's original name # self The instance's current name # args A list of options and their values, possibly empty. proc ::snit::RT.method.configure {type selfns win self args} { # If two or more arguments, set values as usual. if {[llength $args] >= 2} { ::snit::RT.method.configurelist $type $selfns $win $self $args return } # If zero arguments, acquire data for each known option # and return the list if {[llength $args] == 0} { set result {} foreach opt [RT.method.info.options $type $selfns $win $self] { # Refactor this, so that we don't need to call via $self. lappend result [RT.GetOptionDbSpec \ $type $selfns $win $self $opt] } return $result } # They want it for just one. set opt [lindex $args 0] return [RT.GetOptionDbSpec $type $selfns $win $self $opt] } # Retrieves the option database spec for a single option. # # type The snit type # selfns The instance's instance namespace # win The instance's original name # self The instance's current name # option The name of an option # # TBD: This is a bad name. What it's returning is the # result of the configure query. proc ::snit::RT.GetOptionDbSpec {type selfns win self opt} { variable ${type}::Snit_optionInfo namespace upvar $selfns \ Snit_components Snit_components \ options options if {[info exists options($opt)]} { # This is a locally-defined option. Just build the # list and return it. set res $Snit_optionInfo(resource-$opt) set cls $Snit_optionInfo(class-$opt) set def $Snit_optionInfo(default-$opt) return [list $opt $res $cls $def \ [RT.method.cget $type $selfns $win $self $opt]] } elseif {[info exists Snit_optionInfo(target-$opt)]} { # This is an explicitly delegated option. The only # thing we don't have is the default. set res $Snit_optionInfo(resource-$opt) set cls $Snit_optionInfo(class-$opt) # Get the default set logicalName [lindex $Snit_optionInfo(target-$opt) 0] set comp $Snit_components($logicalName) set target [lindex $Snit_optionInfo(target-$opt) 1] if {[catch {$comp configure $target} result]} { set defValue {} } else { set defValue [lindex $result 3] } return [list $opt $res $cls $defValue [$self cget $opt]] } elseif {$Snit_optionInfo(starcomp) ne "" && [lsearch -exact $Snit_optionInfo(except) $opt] == -1} { set logicalName $Snit_optionInfo(starcomp) set target $opt set comp $Snit_components($logicalName) if {[catch {set value [$comp cget $target]} result]} { error "unknown option \"$opt\"" } if {![catch {$comp configure $target} result]} { # Replace the delegated option name with the local name. return [::snit::Expand $result $target $opt] } # configure didn't work; return simple form. return [list $opt "" "" "" $value] } else { error "unknown option \"$opt\"" } } #----------------------------------------------------------------------- # Type Introspection # Implements the standard "info" typemethod. # # type The snit type # command The info subcommand # args All other arguments. proc ::snit::RT.typemethod.info {type command args} { global errorInfo global errorCode switch -exact $command { args - body - default - typevars - typemethods - instances { # TBD: it should be possible to delete this error # handling. set errflag [catch { uplevel 1 [linsert $args 0 \ ::snit::RT.typemethod.info.$command $type] } result] if {$errflag} { return -code error -errorinfo $errorInfo \ -errorcode $errorCode $result } else { return $result } } default { error "\"$type info $command\" is not defined" } } } # Returns a list of the type's typevariables whose names match a # pattern, excluding Snit internal variables. # # type A Snit type # pattern Optional. The glob pattern to match. Defaults # to *. proc ::snit::RT.typemethod.info.typevars {type {pattern *}} { set result {} foreach name [info vars "${type}::$pattern"] { set tail [namespace tail $name] if {![string match "Snit_*" $tail]} { lappend result $name } } return $result } # Returns a list of the type's methods whose names match a # pattern. If "delegate typemethod *" is used, the list may # not be complete. # # type A Snit type # pattern Optional. The glob pattern to match. Defaults # to *. proc ::snit::RT.typemethod.info.typemethods {type {pattern *}} { variable ${type}::Snit_typemethodInfo # FIRST, get the explicit names, skipping prefixes. set result {} foreach name [array names Snit_typemethodInfo -glob $pattern] { if {[lindex $Snit_typemethodInfo($name) 0] != 1} { lappend result $name } } # NEXT, add any from the cache that aren't explicit. # WHD: fixed up to use newstyle method cache/list of subcommands. if {[info exists Snit_typemethodInfo(*)]} { # First, remove "*" from the list. set ndx [lsearch -exact $result "*"] if {$ndx != -1} { set result [lreplace $result $ndx $ndx] } # Next, get the type's -map array set typemethodCache [namespace ensemble configure $type -map] # Next, get matching names from the cache that we don't already # know about. foreach name [array names typemethodCache -glob $pattern] { if {[lsearch -exact $result $name] == -1} { lappend result $name } } } return $result } # $type info args # # Returns a method's list of arguments. does not work for delegated # methods, nor for the internal dispatch methods of multi-word # methods. proc ::snit::RT.typemethod.info.args {type method} { upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo # Snit_methodInfo: method -> list (flag cmd component) # flag : 1 -> internal dispatcher for multi-word method. # 0 -> regular method # # cmd : template mapping from method to command prefix, may # contain placeholders for various pieces of information. # # component : is empty for normal methods. #parray Snit_typemethodInfo if {![info exists Snit_typemethodInfo($method)]} { return -code error "Unknown typemethod \"$method\"" } foreach {flag cmd component} $Snit_typemethodInfo($method) break if {$flag} { return -code error "Unknown typemethod \"$method\"" } if {$component != ""} { return -code error "Delegated typemethod \"$method\"" } set map [list %m $method %j [join $method _] %t $type] set theproc [lindex [string map $map $cmd] 0] return [lrange [::info args $theproc] 1 end] } # $type info body # # Returns a method's body. does not work for delegated # methods, nor for the internal dispatch methods of multi-word # methods. proc ::snit::RT.typemethod.info.body {type method} { upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo # Snit_methodInfo: method -> list (flag cmd component) # flag : 1 -> internal dispatcher for multi-word method. # 0 -> regular method # # cmd : template mapping from method to command prefix, may # contain placeholders for various pieces of information. # # component : is empty for normal methods. #parray Snit_typemethodInfo if {![info exists Snit_typemethodInfo($method)]} { return -code error "Unknown typemethod \"$method\"" } foreach {flag cmd component} $Snit_typemethodInfo($method) break if {$flag} { return -code error "Unknown typemethod \"$method\"" } if {$component != ""} { return -code error "Delegated typemethod \"$method\"" } set map [list %m $method %j [join $method _] %t $type] set theproc [lindex [string map $map $cmd] 0] return [RT.body [::info body $theproc]] } # $type info default # # Returns a method's list of arguments. does not work for delegated # methods, nor for the internal dispatch methods of multi-word # methods. proc ::snit::RT.typemethod.info.default {type method aname dvar} { upvar 1 $dvar def upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo # Snit_methodInfo: method -> list (flag cmd component) # flag : 1 -> internal dispatcher for multi-word method. # 0 -> regular method # # cmd : template mapping from method to command prefix, may # contain placeholders for various pieces of information. # # component : is empty for normal methods. #parray Snit_methodInfo if {![info exists Snit_typemethodInfo($method)]} { return -code error "Unknown typemethod \"$method\"" } foreach {flag cmd component} $Snit_typemethodInfo($method) break if {$flag} { return -code error "Unknown typemethod \"$method\"" } if {$component != ""} { return -code error "Delegated typemethod \"$method\"" } set map [list %m $method %j [join $method _] %t $type] set theproc [lindex [string map $map $cmd] 0] return [::info default $theproc $aname def] } # Returns a list of the type's instances whose names match # a pattern. # # type A Snit type # pattern Optional. The glob pattern to match # Defaults to * # # REQUIRE: type is fully qualified. proc ::snit::RT.typemethod.info.instances {type {pattern *}} { set result {} foreach selfns [namespace children $type "${type}::Snit_inst*"] { namespace upvar $selfns Snit_instance instance if {[string match $pattern $instance]} { lappend result $instance } } return $result } #----------------------------------------------------------------------- # Instance Introspection # Implements the standard "info" method. # # type The snit type # selfns The instance's instance namespace # win The instance's original name # self The instance's current name # command The info subcommand # args All other arguments. proc ::snit::RT.method.info {type selfns win self command args} { switch -exact $command { args - body - default - type - vars - options - methods - typevars - typemethods { set errflag [catch { uplevel 1 [linsert $args 0 ::snit::RT.method.info.$command \ $type $selfns $win $self] } result] if {$errflag} { global errorInfo return -code error -errorinfo $errorInfo $result } else { return $result } } default { # error "\"$self info $command\" is not defined" return -code error "\"$self info $command\" is not defined" } } } # $self info type # # Returns the instance's type proc ::snit::RT.method.info.type {type selfns win self} { return $type } # $self info typevars # # Returns the instance's type's typevariables proc ::snit::RT.method.info.typevars {type selfns win self {pattern *}} { return [RT.typemethod.info.typevars $type $pattern] } # $self info typemethods # # Returns the instance's type's typemethods proc ::snit::RT.method.info.typemethods {type selfns win self {pattern *}} { return [RT.typemethod.info.typemethods $type $pattern] } # Returns a list of the instance's methods whose names match a # pattern. If "delegate method *" is used, the list may # not be complete. # # type A Snit type # selfns The instance namespace # win The original instance name # self The current instance name # pattern Optional. The glob pattern to match. Defaults # to *. proc ::snit::RT.method.info.methods {type selfns win self {pattern *}} { variable ${type}::Snit_methodInfo # FIRST, get the explicit names, skipping prefixes. set result {} foreach name [array names Snit_methodInfo -glob $pattern] { if {[lindex $Snit_methodInfo($name) 0] != 1} { lappend result $name } } # NEXT, add any from the cache that aren't explicit. # WHD: Fixed up to use newstyle method cache/list of subcommands. if {[info exists Snit_methodInfo(*)]} { # First, remove "*" from the list. set ndx [lsearch -exact $result "*"] if {$ndx != -1} { set result [lreplace $result $ndx $ndx] } # Next, get the instance's -map set self [set ${selfns}::Snit_instance] array set methodCache [namespace ensemble configure $self -map] # Next, get matching names from the cache that we don't already # know about. foreach name [array names methodCache -glob $pattern] { if {[lsearch -exact $result $name] == -1} { lappend result $name } } } return $result } # $self info args # # Returns a method's list of arguments. does not work for delegated # methods, nor for the internal dispatch methods of multi-word # methods. proc ::snit::RT.method.info.args {type selfns win self method} { upvar ${type}::Snit_methodInfo Snit_methodInfo # Snit_methodInfo: method -> list (flag cmd component) # flag : 1 -> internal dispatcher for multi-word method. # 0 -> regular method # # cmd : template mapping from method to command prefix, may # contain placeholders for various pieces of information. # # component : is empty for normal methods. #parray Snit_methodInfo if {![info exists Snit_methodInfo($method)]} { return -code error "Unknown method \"$method\"" } foreach {flag cmd component} $Snit_methodInfo($method) break if {$flag} { return -code error "Unknown method \"$method\"" } if {$component != ""} { return -code error "Delegated method \"$method\"" } set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self] set theproc [lindex [string map $map $cmd] 0] return [lrange [::info args $theproc] 4 end] } # $self info body # # Returns a method's body. does not work for delegated # methods, nor for the internal dispatch methods of multi-word # methods. proc ::snit::RT.method.info.body {type selfns win self method} { upvar ${type}::Snit_methodInfo Snit_methodInfo # Snit_methodInfo: method -> list (flag cmd component) # flag : 1 -> internal dispatcher for multi-word method. # 0 -> regular method # # cmd : template mapping from method to command prefix, may # contain placeholders for various pieces of information. # # component : is empty for normal methods. #parray Snit_methodInfo if {![info exists Snit_methodInfo($method)]} { return -code error "Unknown method \"$method\"" } foreach {flag cmd component} $Snit_methodInfo($method) break if {$flag} { return -code error "Unknown method \"$method\"" } if {$component != ""} { return -code error "Delegated method \"$method\"" } set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self] set theproc [lindex [string map $map $cmd] 0] return [RT.body [::info body $theproc]] } # $self info default # # Returns a method's list of arguments. does not work for delegated # methods, nor for the internal dispatch methods of multi-word # methods. proc ::snit::RT.method.info.default {type selfns win self method aname dvar} { upvar 1 $dvar def upvar ${type}::Snit_methodInfo Snit_methodInfo # Snit_methodInfo: method -> list (flag cmd component) # flag : 1 -> internal dispatcher for multi-word method. # 0 -> regular method # # cmd : template mapping from method to command prefix, may # contain placeholders for various pieces of information. # # component : is empty for normal methods. if {![info exists Snit_methodInfo($method)]} { return -code error "Unknown method \"$method\"" } foreach {flag cmd component} $Snit_methodInfo($method) break if {$flag} { return -code error "Unknown method \"$method\"" } if {$component != ""} { return -code error "Delegated method \"$method\"" } set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self] set theproc [lindex [string map $map $cmd] 0] return [::info default $theproc $aname def] } # $self info vars # # Returns the instance's instance variables proc ::snit::RT.method.info.vars {type selfns win self {pattern *}} { set result {} foreach name [info vars "${selfns}::$pattern"] { set tail [namespace tail $name] if {![string match "Snit_*" $tail]} { lappend result $name } } return $result } # $self info options # # Returns a list of the names of the instance's options proc ::snit::RT.method.info.options {type selfns win self {pattern *}} { variable ${type}::Snit_optionInfo # First, get the local and explicitly delegated options set result [concat $Snit_optionInfo(local) $Snit_optionInfo(delegated)] # If "configure" works as for Tk widgets, add the resulting # options to the list. Skip excepted options if {$Snit_optionInfo(starcomp) ne ""} { namespace upvar $selfns Snit_components Snit_components set logicalName $Snit_optionInfo(starcomp) set comp $Snit_components($logicalName) if {![catch {$comp configure} records]} { foreach record $records { set opt [lindex $record 0] if {[lsearch -exact $result $opt] == -1 && [lsearch -exact $Snit_optionInfo(except) $opt] == -1} { lappend result $opt } } } } # Next, apply the pattern set names {} foreach name $result { if {[string match $pattern $name]} { lappend names $name } } return $names } proc ::snit::RT.body {body} { regsub -all ".*# END snit method prolog\n" $body {} body return $body } tcltk2/inst/tklibs/snit2.3.4/dictionary.txt0000644000176200001440000001153015017041713020171 0ustar liggesusersLast updated: Snit V1.0 TYPE VARIABLES Snit_info Introspection Array. Keys and values are as follows: hasinstances Boolean. Normally T, but F if pragma -hasinstances no simpledispatch Uses a very simple method dispatcher. canreplace Boolean. Normally F, but T if pragma -canreplace yes counter Integer counter. Used to generate unique names. widgetclass Tk widget class name for snit::widgets hulltype Hull widget type (frame or toplevel) for snit::widgets. ns The type namespace, "$type::". UNUSED. exceptmethods Method names excluded from delegate method *. excepttypemethods Typemethod names excluded from delegate typemethod *. tvardecs Type variable declarations--for dynamic methods. ivardecs Instance variable declarations--for dynamic methods. isWidget Boolean; true if object is a widget or widgetadaptor. isWidgetAdaptor Boolean; true if object is a widgetadaptor Snit_methods List of method names; defined only when -simpledispatch yes. Snit_typemethodInfo Array(method name) = { ? ?} where is 1 if the method has submethods (in which case the other fields are missing) and 0 if it doesn't. is "" for normal typemethods and "method name" can be "*". Used in typemethod cache lookup to create the command for the named typemethod. Snit_typecomponents Array(typecomponent name) = command_name Used whenever we need to retrieve the typecomponent's command. Snit_methodInfo Array(method name) = { ? ?} where is 1 if the method has submethods (in which case the other fields are missing) and 0 if it doesn't. is "" for normal methods and "method name" can be "*". Used in method cache lookup to create the command for the named method. Snit_optionInfo An array of option data. The keys are as follows: General fields: local List of local option names. delegated List of explicitly delegated option names. starcomp Name of component for "delegate option *" or "" except List of option names explicitly NOT delegated by "delegate option *". Fields defined for all locally defined and explicitly delegated options: islocal-$opt 1 if local, 0 otherwise. Currently undefined for "delegate option *" options. resource-$opt The option's resource name. class-$opt The option's class name. Fields defined only for locally defined options default-$localOpt Default value. validate-$localOpt The name of the validate method, or "". configure-$localOpt The name of the configure method, or "". cget-$localOpt The name of the cget method, or "". readonly-$localOpt true or false. (false is the default). typespec-$localOpt Validation type specification (object name or construction list) typeobj-$localOpt Validation type object Fields defined only for delegated options delegated-$comp List of option names delegated to this component. target-$opt [list component targetOptionName]. INSTANCE VARIABLES Snit_iinfo Array, instance info. At some point, Snit_instance and Snit_components should probably be consolidated into it. The fields are: constructed 0 during instance construction, and 1 after. Snit_instance Current name of the instance command. Snit_components Array(component name) = command_name Used whenever we need to retrieve the component's command. Consider consolidating the following arrays into a single array, since they are all cleared at the same time. Snit_cgetCache Array(option name) = cached command. Used by $self cget. Snit_configureCache Array(option name) = cached command. Used by $self configurelist. Snit_validateCache Array(option name) = cached command. Used by $self configurelist. The entry is "" if there is no validate command. tcltk2/inst/tklibs/ipentry0.3/0000755000176200001440000000000015017102465015636 5ustar liggesuserstcltk2/inst/tklibs/ipentry0.3/ipentry.tcl0000644000176200001440000007112215017041713020035 0ustar liggesusers# ipentry.tcl -- # # An entry widget for IP addresses. # # Copyright (c) 2003-2008 Aaron Faupell # Copyright (c) 2008 Pat Thoyts # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require Tk package provide ipentry 0.3.2 namespace eval ::ipentry { namespace export ipentry ipentry6 # copy all the bindings from Entry class to our own IPEntrybindtag class variable x foreach x [bind Entry] { bind IPEntrybindtag $x [bind Entry $x] } # then replace certain keys we are interested in with our own bind IPEntrybindtag {::ipentry::keypress %W %K} bind IPEntrybindtag {::ipentry::backspace %W} bind IPEntrybindtag {::ipentry::dot %W} bind IPEntrybindtag {::ipentry::arrow %W %K} bind IPEntrybindtag {::ipentry::arrow %W %K} bind IPEntrybindtag {::ipentry::FocusIn %W} bind IPEntrybindtag {::ipentry::FocusOut %W} bind IPEntrybindtag <> {::ipentry::Paste %W CLIPBOARD} bind IPEntrybindtag <> {::ipentry::Paste %W PRIMARY} # copy all the bindings from IPEntrybindtag foreach x [bind IPEntrybindtag] { bind IPEntrybindtag6 $x [bind IPEntrybindtag $x] } # and replace certain keys with ip6 bindings bind IPEntrybindtag6 {::ipentry::keypress %W %K 6} bind IPEntrybindtag6 {::ipentry::dot %W} bind IPEntrybindtag6 {} #if {[package vsatisfies [package provide Tk] 8.5-]} { # ttk::style layout IPEntryFrame { # Entry.field -sticky news -border 1 -children { # IPEntryFrame.padding -sticky news # } # } # bind [winfo class .] <> \ # [list +ttk::style layout IPEntryFrame \ # [ttk::style layout IPEntryFrame]] # } unset x } # ipentry -- # # main entry point - construct a new ipentry widget # # ARGS: # w path name of widget to create # # see ::ipentry::configure for args # # RETURNS: # the widget path name # proc ::ipentry::ipentry {w args} { upvar #0 [namespace current]::widget_$w state #set state(themed) [package vsatisfies [package provide Tk] 8.5-] set state(themed) 0 foreach {name val} $args { if {$name eq "-themed"} { set state(themed) $val } } if {$state(themed)} { ttk::frame $w -style IPEntryFrame -class IPEntry -takefocus 0 } else { frame $w -relief sunken -class IPEntry;#-padx 5 } foreach x {0 1 2 3} y {d1 d2 d3 d4} { #if {$state(themed)} { # ttk::entry $w.$x -width 3 -justify center # ttk::label $w.$y -text . #} entry $w.$x -borderwidth 0 -width 3 -highlightthickness 0 \ -justify center -takefocus 0 label $w.$y -borderwidth 0 -font [$w.$x cget -font] -width 1 -text . \ -justify center -cursor [$w.$x cget -cursor] \ -background [$w.$x cget -background] \ -disabledforeground [$w.$x cget -disabledforeground] pack $w.$x $w.$y -side left bindtags $w.$x [list $w.$x IPEntrybindtag . all] bind $w.$y {::ipentry::dotclick %W %x} } destroy $w.d4 $w.0 configure -takefocus 1 if {$state(themed)} { pack configure $w.0 -padx {1 0} -pady 1 pack configure $w.3 -padx {0 1} -pady 1 -fill x -expand 1 $w.3 configure -justify left } else { $w configure -borderwidth [lindex [$w.0 configure -bd] 3] #-background [$w.0 cget -bg] } rename ::$w ::ipentry::_$w # redirect the widget name command to the widgetCommand dispatcher interp alias {} ::$w {} ::ipentry::widgetCommand $w bind $w [list ::ipentry::destroyWidget $w] if {[llength $args] > 0} { eval [list $w configure] $args } return $w } # ipentry -- # # main entry point - construct a new ipentry6 widget # # ARGS: # w path name of widget to create # # see ::ipentry::configure for args # # RETURNS: # the widget path name # proc ::ipentry::ipentry6 {w args} { upvar #0 [namespace current]::widget_$w state #set state(themed) [package vsatisfies [package provide Tk] 8.5-] set state(themed) 0 foreach {name val} $args { if {$name eq "-themed"} { set state(themed) $val } } if {$state(themed)} { ttk::frame $w -style IPEntryFrame -class IPEntry -takefocus 0 } else { frame $w -relief sunken -class IPEntry;#-padx 5 } foreach x {0 1 2 3 4 5 6 7} y {d1 d2 d3 d4 d5 d6 d7 d8} { entry $w.$x -borderwidth 0 -width 4 -highlightthickness 0 \ -justify center -takefocus 0 label $w.$y -borderwidth 0 -font [$w.$x cget -font] -width 1 -text : \ -justify center -cursor [$w.$x cget -cursor] \ -background [$w.$x cget -background] \ -disabledforeground [$w.$x cget -disabledforeground] pack $w.$x $w.$y -side left bindtags $w.$x [list $w.$x IPEntrybindtag6 . all] bind $w.$y {::ipentry::dotclick %W %x} } destroy $w.d8 $w.0 configure -takefocus 1 if {$state(themed)} { pack configure $w.0 -padx {1 0} -pady 1 pack configure $w.7 -padx {0 1} -pady 1 -fill x -expand 1 $w.7 configure -justify left } else { $w configure -borderwidth [lindex [$w.0 configure -bd] 3] #-background [$w.0 cget -bg] } rename ::$w ::ipentry::_$w # redirect the widget name command to the widgetCommand dispatcher interp alias {} ::$w {} ::ipentry::widgetCommand6 $w bind $w [list ::ipentry::destroyWidget $w] if {[llength $args] > 0} { eval [list $w configure] $args } return $w } # keypress -- # # called every time a key is pressed in an ipentry widget # used by both ipentry and ipentry6 # # ARGS: # w window argument (%W) from the event binding # key the keysym (%K) from the event # type empty string or "6" depending on the type of ipentry # # RETURNS: # nothing # proc ::ipentry::keypress {w key {type {}}} { if {![validate$type $w $key]} { return } # sel.first and sel.last throw an error if the selection isnt in $w catch { set insert [$w index insert] # if a key is pressed while there is a selection then delete the # selected chars if {([$w index sel.first] <= $insert) && ([$w index sel.last] >= $insert)} { $w delete sel.first sel.last } } $w insert insert $key ::ipentry::updateTextvar $w } # backspace -- # # called when the Backspace key is pressed in an ipentry widget # used by both ipentry and ipentry6 # # try to act like a normal backspace except if the cursor is at index 0 # of one entry we need to move to the end of the preceding entry # # ARGS: # w window argument (%W) from the event binding # # RETURNS: # nothing # proc ::ipentry::backspace {w} { if {[$w selection present]} { $w delete sel.first sel.last } else { if {[$w index insert] == 0} { set w [skip $w prev] } $w delete [expr {[$w index insert] - 1}] } ::ipentry::updateTextvar $w } # dot -- # # called when the dot (Period) key is pressed in an ipentry widget # used by both ipentry and ipentry6 # # treat the current entry as done and move to the next entry field # # ARGS: # w window argument (%W) from the event binding # # RETURNS: # nothing # proc ::ipentry::dot {w} { if {[string length [$w get]] > 0} { skip $w next 1 } ::ipentry::updateTextvar $w } # FocusIn -- # # called when the focus enters any of the child widgets of an ipentry # used by both ipentry and ipentry6 # # clear the selection of all child widgets other than the one with focus # # ARGS: # w window argument (%W) from the event binding # # RETURNS: # nothing # proc ::ipentry::FocusIn {w} { set p [winfo parent $w] foreach x {0 1 2 3 4 5 6 7} { if {![winfo exists $p.$x]} { break } if {"$p.$x" != $w} { $p.$x selection clear } } } # FocusOut -- # # called when the focus leaves any of the child widgets of an ipentry # used by both ipentry and ipentry6 # # dont allow a 0 in the first quad # # ARGS: # w window argument (%W) from the event binding # # RETURNS: # nothing # proc ::ipentry::FocusOut {w} { set s [$w get] if {[string match {*.0} $w] && $s != "" && $s < 1} { $w delete 0 end $w insert end 1 ::ipentry::updateTextvar $w } # trim off leading zeros if {[string length $s] > 1} { set n [string trimleft $s 0] if {$n eq ""} { set n 0 } if {![string equal $n $s]} { $w delete 0 end $w insert end $n } } } # Paste -- # # called from the <> virtual event # used by ipentry only # # clear the selection of all child widgets other than the one with focus # # ARGS: # w window argument (%W) from the event binding # sel one of CLIPBOARD or PRIMARY # # RETURNS: # nothing # proc ::ipentry::Paste {w sel} { if {[catch {::tk::GetSelection $w $sel} paste]} { return } $w delete 0 end foreach char [split $paste {}] { # ignore everything except dots and digits if {![string match {[0123456789.]} $char]} { continue } if {$char != "."} { $w insert end $char } # if value is over 255 truncate it if {[$w get] > 255} { $w delete 0 end $w insert 0 255 } # if char is a . then get the index of the current entry # and update $w to point to the next entry if {$char == "."} { set n [string index $w end] if { $n >= 3 } { return } set w [string trimright $w "0123"][expr {$n + 1}] $w delete 0 end continue } } ::ipentry::updateTextvar $w } # Paste6 -- # # called from the <> virtual event # used by both ipentry6 only # # clear the selection of all child widgets other than the one with focus # # ARGS: # w window argument (%W) from the event binding # sel one of CLIPBOARD or PRIMARY # # RETURNS: # nothing # proc ::ipentry::Paste6 {w sel} { if {[catch {::tk::GetSelection $w $sel} paste]} { return } $w delete 0 end foreach char [split $paste {}] { # ignore everything except colons and hex digits if {![string match {[0123456789abcdefABCDEF:]} $char]} { continue } if {$char != ":"} { $w insert end $char } # if char is a : then get the index of the current entry # and update $w to point to the next entry if {$char == ":"} { set n [string index $w end] if { $n >= 7 } { return } set w [string trimright $w "01234567"][expr {$n + 1}] $w delete 0 end continue } } ::ipentry::updateTextvar $w } # dotclick -- # # called when mouse button 1 is clicked on any of the label widgets # used by both ipentry and ipentry6 # # decide which side of the dot was clicked and put the focus and cursor # in the correct entry # # ARGS: # w window argument (%W) from the event binding # # RETURNS: # nothing # proc ::ipentry::dotclick {w x} { if {$x > ([winfo width $w] / 2)} { set w [winfo parent $w].[string index $w end] focus $w $w icursor 0 } else { set w [winfo parent $w].[expr {[string index $w end] - 1}] focus $w $w icursor end } } # arrow -- # # called when the left or right arrow keys are pressed in an ipentry # used by both ipentry and ipentry6 # # ARGS: # w window argument (%W) from the event binding # key one of Left or Right # # RETURNS: # nothing # proc ::ipentry::arrow {w key} { set i [$w index insert] set l [string length [$w get]] # move the icursor +1 or -1 position $w icursor [expr $i [string map {Right + Left -} $key] 1] $w selection clear # if we are moving right and the cursor is at the end, or the entry is empty if {$key == "Right" && ($i == $l || $l == 0)} { skip $w next } elseif {$key == "Left" && $i == 0} { skip $w prev } } # validate -- # # called by keypress to validate the input # used by ipentry only # # ARGS: # w window argument (%W) from the event binding # key the key pressed # # RETURNS: # a boolean indicating if the key is valid or not # proc ::ipentry::validate {w key} { if {![string match {[0123456789]} $key]} { return 0 } set curval [$w get] set insert [$w index insert] # dont allow more than a single 0 to be entered if {$curval == "0" && $key == "0"} { return 0 } if {[string length $curval] == 2} { set curval [join [linsert [split $curval {}] $insert $key] {}] if {$curval > 255} { $w delete 0 end $w insert 0 255 $w selection range 0 end ::ipentry::updateTextvar $w return 0 } elseif {$insert == 2} { skip $w next 1 } return 1 } if {[string length $curval] >= 3 && ![$w selection present]} { if {$insert == 3} { skip $w next 1 } return 0 } return 1 } # validate6 -- # # called by keypress to validate the input # used by ipentry6 only # # ARGS: # w window argument (%W) from the event binding # key the key pressed # # RETURNS: # a boolean indicating if the key is valid or not # proc ::ipentry::validate6 {w key} { if {![string is xdigit $key]} { return 0 } set curval 0x[$w get] set insert [$w index insert] # dont allow more than a single 0 to be entered if {$curval == "0" && $key == "0"} { return 0 } if {[string length $curval] == 5} { set curval [join [linsert [split $curval {}] $insert $key] {}] if {$insert == 3} { skip $w next 1 } return 1 } if {[string length $curval] >= 6 && ![$w selection present]} { if {$insert == 4} { skip $w next 1 } return 0 } return 1 } # skip -- # # move the cursor to the previous or next entry widget # used by both ipentry and ipentry6 # # ARGS: # w name of the current entry widget # dir direction to move, one of next or prev # sel boolean indicating whether to select the digits in the next entry # # RETURNS: # the name of the widget with focus # proc ::ipentry::skip {w dir {sel 0}} { set n [string index $w end] if {$dir == "next"} { set next [string trimright $w "012345678"][expr {$n + 1}] if { ![winfo exists $next] } { return $w } focus $next if {$sel} { $next icursor 0 $next selection range 0 end } return $next } else { if { $n <= 0 } { return $w } set prev [string trimright $w "012345678"][expr {$n - 1}] focus $prev $prev icursor end return $prev } } # _foreach -- # # utility for the widget configure command # # perform a command on every subwidget of an ipentry frame # # ARGS: # w name of the ipentry frame # cmd command to perform # type one of empty, "entry", or "dot" # # RETURNS: # nothing # proc ::ipentry::_foreach {w cmd {type {}}} { if {$type == "" || $type == "entry"} { foreach x {0 1 2 3 4 5 6 7} { if {![winfo exists $w.$x]} { break } eval [list $w.$x] $cmd } } if {$type == "" || $type == "dot"} { foreach x {d1 d2 d3 d4 d5 d6 d7} { if {![winfo exists $w.$x]} { break } eval [list $w.$x] $cmd } } } # cget -- # # handle the widgetName cget subcommand # used by both ipentry and ipentry6 # # ARGS: # w name of the ipentry widget # cmd name of a configuration option # # RETURNS: # the value of the requested option # proc ::ipentry::cget {w cmd} { upvar #0 [namespace current]::widget_$w state switch -exact -- $cmd { -bd - -borderwidth - -relief { # for bd and relief return the value from the container frame if {!$state(themed)} { return [::ipentry::_$w cget $cmd] } } -textvariable { if {[info exists ::ipentry::textvars($w)]} { return $::ipentry::textvars($w) } return {} } -themed { return $state(themed) } -takefocus { return 0 } default { # for all other commands return the value from the first entry return [$w.0 cget $cmd] } } } # configure -- # # handle the widgetName configure subcommand # used by both ipentry and ipentry6 # # ARGS: # w name of the ipentry widget # args name/value pairs of configuration options # # RETURNS: # nothing # proc ::ipentry::configure {w args} { upvar #0 [namespace current]::widget_$w Priv while {[set cmd [lindex $args 0]] != ""} { switch -exact -- $cmd { -state { set state [lindex $args 1] if {$state == "disabled"} { _foreach $w [list configure -state disabled] if {[set dbg [$w.0 cget -disabledbackground]] == ""} { set dbg [$w.0 cget -bg] } _foreach $w [list configure -bg $dbg] dot if {$Priv(themed)} { ::ipentry::_$w state disabled } else { ::ipentry::_$w configure -background $dbg } } elseif {$state == "normal"} { _foreach $w [list configure -state normal] _foreach $w [list configure -bg [$w.0 cget -bg]] dot if {$Priv(themed)} { ::ipentry::_$w state {!readonly !disabled} } else { ::ipentry::_$w configure -background [$w.0 cget -bg] } } elseif {$state == "readonly"} { _foreach $w [list configure -state readonly] entry if {[set robg [$w.0 cget -readonlybackground]] == ""} { set robg [$w.0 cget -bg] } _foreach $w [list configure -bg $robg] dot if {$Priv(themed)} { ::ipentry::_$w state !readonly } else { ::ipentry::_$w configure -background $robg } } set args [lrange $args 2 end] } -bg - -background { set bg [lindex $args 1] _foreach $w [list configure -background $bg] if {!$Priv(themed)} { ::ipentry::_$w configure -background $bg } set args [lrange $args 2 end] } -disabledforeground { _foreach $w [list configure -disabledforeground [lindex $args 1]] set args [lrange $args 2 end] } -font - -fg - -foreground { _foreach $w [list configure $cmd [lindex $args 1]] set args [lrange $args 2 end] } -bd - -borderwidth - -relief - -highlightcolor - -highlightbackground - -highlightthickness { _$w configure $cmd [lindex $args 1] set args [lrange $args 2 end] } -readonlybackground - -disabledbackground - -selectforeground - -selectbackground - -selectborderwidth - -insertbackground { _foreach $w [list configure $cmd [lindex $args 1]] entry set args [lrange $args 2 end] } -themed { # ignored - only used in widget creation } -textvariable { set name [lindex $args 1] upvar #0 $name var #if {![string match ::* $name]} { set name ::$name } if {[info exists ::ipentry::textvars($w)]} { set trace [trace info variable var] trace remove variable var [lindex $trace 0 0] [lindex $trace 0 1] } set ::ipentry::textvars($w) $name if {![info exists var]} { set var "" } ::ipentry::traceFired $w $name {} write if {[winfo exists $w.4]} { trace add variable var {write unset} [list ::ipentry::traceFired6 $w] } else { trace add variable var {write unset} [list ::ipentry::traceFired $w] } set args [lrange $args 2 end] } default { error "unknown option \"[lindex $args 0]\"" } } } } # destroyWidget -- # # bound to the event # used by both ipentry and ipentry6 # # ARGS: # w name of the ipentry widget # # RETURNS: # nothing # proc ::ipentry::destroyWidget {w} { upvar #0 [namespace current]::widget_$w state if {[info exists ::ipentry::textvars($w)]} { upvar #0 $::ipentry::textvars($w) var set trace [trace info variable var] trace remove variable var [lindex $trace 0 0] [lindex $trace 0 1] } rename $w {} unset state } # traceFired -- # # called by the variable trace on the ipentry textvariable # used by ipentry only # # ARGS: # w name of the ipentry widget # varname name of the variable being traced # key array index of the variable # op operation performed on the variable, read/write/unset # # RETURNS: # nothing # proc ::ipentry::traceFired {w name key op} { upvar #0 $name var if {[info level] > 1} { set caller [lindex [info level -1] 0] if {$caller == "::ipentry::updateTextvar" || $caller == "::ipentry::traceFired"} { return } } if {$op == "write"} { _insert $w [split $var .] set val [string trim [join [$w get] .] .] # allow a dot at the end, but only if we have less than 3 already if {[string index $var end] == "." && [regexp -all {\.+} $var] <= 3} { append val . } if {$val eq $var} return after 0 [list set $name $val] set var $val } elseif {$op == "unset"} { ::ipentry::updateTextvar $w.0 trace add variable var {write unset} [list ipentry::traceFired $w] } } # traceFired6 -- # # called by the variable trace on the ipentry textvariable # used by ipentry6 only # # ARGS: # w name of the ipentry widget # varname name of the variable being traced # key array index of the variable # op operation performed on the variable, read/write/unset # # RETURNS: # nothing # proc ::ipentry::traceFired6 {w name key op} { upvar #0 $name var if {[info level] > 1} { set caller [lindex [info level -1] 0] if {$caller == "::ipentry::updateTextvar" || $caller == "::ipentry::traceFired6"} { return } } if {$op == "write"} { _insert6 $w [split $var :] set val [string trim [join [$w get] :] :] # allow a dot at the end, but only if we have less than 3 already if {[string index $var end] == ":" && [regexp -all {\:+} $var] <= 7} { append val : } if {$val eq $var} return after 0 [list set $name $val] set var $val } elseif {$op == "unset"} { ::ipentry::updateTextvar $w.0 trace add variable var {write unset} [list ipentry::traceFired6 $w] } } # updateTextvar -- # # called by all procs which change the value of the ipentry # used by both ipentry and ipentry6 # # update the textvariable if it exists with the new value # # ARGS: # w name of the ipentry widget # # RETURNS: # nothing # proc ::ipentry::updateTextvar {w} { set p [winfo parent $w] if {![info exists ::ipentry::textvars($p)]} { return } set c [$p.d1 cget -text] set val [string trim [join [$p get] $c] $c] upvar #0 $::ipentry::textvars($p) var if {[info exists var] && $var == $val} { return } set var $val } # _insert -- # # called by the variable trace on the ipentry textvariable and widget insert cmd # used by ipentry only # # ARGS: # w name of an ipentry widget # val a list of 4 values to be inserted into the ipentry # # RETURNS: # nothing # proc ::ipentry::_insert {w val} { foreach x {0 1 2 3} { set n [lindex $val $x] if {$n != ""} { ##nagelfar ignore if {![string is integer -strict $n]} { #error "cannot insert non-numeric arguments" return } if {$n > 255} { set n 255 } if {$n <= 0} { set n 0 } if {$x == 0 && $n < 1} { set n 1 } } $w.$x delete 0 end $w.$x insert 0 $n } } # _insert6 -- # # called by the variable trace on the ipentry textvariable and widget insert cmd # used by both ipentry6 only # # ARGS: # w name of an ipentry widget # val a list of 8 values to be inserted into the ipentry # # RETURNS: # nothing # proc ::ipentry::_insert6 {w val} { foreach x {0 1 2 3 4 5 6 7} { set n [lindex $val $x] if {![string is xdigit $n]} { #error "cannot insert non-hex arguments" return } if {$n != "" } { if "$x == 0 && 0x$n < 1" { set n 1 } if "0x$n > 0xffff" { set n ffff } } $w.$x delete 0 end $w.$x insert 0 $n } } # widgetCommand -- # # handle the widgetName command # used by ipentry, with some commands passed through from widgetCommand6 # # ARGS: # w name of the ipentry widget # cmd the subcommand # args arguments to the subcommand # # RETURNS: # the results of the invoked subcommand # proc ::ipentry::widgetCommand {w cmd args} { upvar #0 [namespace current]::widget_$w state switch -exact -- $cmd { get { # return the 4 entry values as a list foreach x {0 1 2 3 4 5 6 7} { if {![winfo exists $w.$x]} { break } set s [$w.$x get] if {[string length $s] > 1} { set s [string trimleft $s 0] if {$s == ""} { set s 0 } } lappend r $s } return $r } insert { _insert $w [join $args] ::ipentry::updateTextvar $w.3 } icursor { if {![string match $w.* [focus]]} { return } set i [lindex $args 0] ##nagelfar ignore if {![string is integer -strict $i]} { return -code error "argument must be an integer" } set s [expr {$i / 4}] focus $w.$s $w.$s icursor [expr {$i % 4}] } complete { foreach x {0 1 2 3 4 5 6 7} { if {![winfo exists $w.$x]} { break } if {[$w.$x get] == ""} { return 0 } } return 1 } configure { eval [list ::ipentry::configure $w] $args } cget { return [::ipentry::cget $w [lindex $args 0]] } default { error "bad option \"$cmd\": must be get, insert, complete, cget, or configure" } } } # widgetCommand6 -- # # handle the widgetName command for ipentry6 widgets # most subcommands are passed through to widgetCommand by the default case # # ARGS: # w name of the ipentry widget # cmd the subcommand # args arguments to the subcommand # # RETURNS: # the results of the invoked subcommand # proc ::ipentry::widgetCommand6 {w cmd args} { upvar #0 [namespace current]::widget_$w state switch -exact -- $cmd { insert { _insert6 $w [join $args] ::ipentry::updateTextvar $w.7 } icursor { if {![string match $w.* [focus]]} { return } set i [lindex $args 0] ##nagelfar ignore if {![string is integer -strict $i]} { return -code error "argument must be an integer" } set s [expr {$i / 8}] focus $w.$s $w.$s icursor [expr {$i % 8}] } default { return [eval [list ::ipentry::widgetCommand $w $cmd] $args] } } } tcltk2/inst/tklibs/ipentry0.3/pkgIndex.tcl0000644000176200001440000000021615017041713020110 0ustar liggesusersif { ![package vsatisfies [package provide Tcl] 8.4-] } { return } package ifneeded ipentry 0.3.2 [list source [file join $dir ipentry.tcl]] tcltk2/inst/tklibs/ipentry0.3/ipentry.man0000644000176200001440000000777615017041713020044 0ustar liggesusers[vset VERSION 0.3.2] [comment {-*- tcl -*- doctools manpage}] [manpage_begin ipentry n [vset VERSION]] [keywords entry] [keywords {ip address}] [keywords network] [moddesc {An IP address entry widget}] [titledesc {An IP address entry widget}] [category Widget] [require Tcl 8.4] [require Tk 8.4] [require ipentry [opt [vset VERSION]]] [description] This package provides a widget for the entering of a IP address. [para] [list_begin definitions] [call [cmd ::ipentry::ipentry] [arg pathName] [opt "[arg option] [arg value]..."]] Creates a new IPv4 ipentry widget and configures it with the given options and their values. [call [cmd ::ipentry::ipentry6] [arg pathName] [opt "[arg option] [arg value]..."]] Creates a new ipentry widget for the entry of an IPv6 address. All options are the same as the IPv4 widget. [list_end] Each widget created with the command above supports the following methods: [list_begin definitions] [call [arg pathName] [method complete]] Returns a boolean value. True indicates that the entry contains a complete IP address, meaning all fields have a value. In some cases IPv6 address are valid when fields are missing. You will need to do your own validation to detect this. [call [arg pathName] [method get]] Returns the contents of the entry as a list consisting of 4 or 8 elements. [call [arg pathName] [method insert] [arg iplist]] IPv4 Takes a list of 4 elements and inserts one into each quad of the entry, in order. All values in the list must be empty or integers. Values outside the range 0 to 255 are modified to be within the range. IPv6 Takes a list of 8 elements and inserts one into each quad of the entry, in order. All values in the list must be empty or 1 to 4 hex digits. [call [arg pathName] [method icursor] [arg index]] Sets the position of the widgets insertion cursor. Only integer values between 0 and 15 are valid for ipentry and 0 to 31 for ipentry6. Setting the icursor will only have an effect if the widget already has the input focus. [call [arg pathName] [method configure] [arg option] [arg value]...] Modifies the configuration of the widget. For options and their meaning see the widget options section. [call [arg pathName] [method cget] [arg option]] Returns information about the current configuration of the widget, for the specified option. For options and their meaning see the widget options section. [list_end] [section {Widget options}] [list_begin tkoptions] [tkoption_def -textvariable textvariable Variable] The name of a variable which holds the value of the IP address. The value must be a string of the form NNN.NNN.NNN.NNN for IPv4 or HHHH:HHHH:HHHH:HHHH:HHHH:HHHH:HHHH:HHHH for IPv6 where H is a hex digit. The variable will be modified to represent a valid IP address if it is not already. [tkoption_def -state state State] Specifies one of three states for the entry: [const normal], [const disabled], or [const readonly]. [tkoption_def -font font Font] [tkoption_def -bd borderWidth BorderWidth] [tkoption_def -fg foreground Foreground] [tkoption_def -bg background Background] [tkoption_def -relief relief Relief] [tkoption_def -highlightthickness highlightThickness HighlightThickness] [tkoption_def -highlightcolor highlightColor HighlightColor] [tkoption_def -highlightbackground highlightBackground HighlightBackground] [tkoption_def -selectbackground selectBackground Background] [tkoption_def -selectforeground selectForeground Foreground] [tkoption_def -selectborderwidth selectBorderWidth BorderWidth] [tkoption_def -disabledbackground disabledBackground DisabledBackground] [tkoption_def -disabledforeground disabledForeground DisabledForeground] [tkoption_def -readonlybackground readonlyBackground ReadonlyBackground] [tkoption_def -insertbackground insertBackground Background] Standard widget options. See [cmd options] for a description of their meanings and values. [list_end] [vset CATEGORY ipentry] [include ../../support/devel/doc/feedback.inc] [manpage_end] tcltk2/inst/tklibs/ipentry0.3/ChangeLog0000644000176200001440000000413115017041713017405 0ustar liggesusers2020-02-09 0.7 * * Released and tagged Tklib 0.7 ======================== * 2013-03-25 Andreas Kupries * * Released and tagged Tklib 0.6 ======================== * 2009-01-21 Andreas Kupries * * Released and tagged Tklib 0.5 ======================== * 2008-11-29 Aaron Faupell * ipentry.tcl: use -takefocus instead of tab bindings. this works in reverse circulation too. also a fix when unsetting the textvariable 2008-11-29 Aaron Faupell * ipentry.tcl: add ipentry6 widget for IPv6 addresses * ipentry.man: document ipentry6 2008-11-28 Aaron Faupell * ipentry.tcl: fix textvariable. should work like a normal widget now 2008-11-27 Pat Thoyts * ipentry.tcl: Use the ttk::entry border if ttk available * ipentry.man: Document -themed 0 to disable themed look * pkgIndex.tcl: Incremented version to 0.3 2006-07-14 Aaron Faupell * ipentry.tcl: added -textvariable option, and bumped version * ipentry.man: added docs for -textvariable option thanks to Chris Maj for the patch 2005-11-10 Andreas Kupries * * Released and tagged Tklib 0.4.1 ======================== * 2005-11-02 Andreas Kupries * * Released and tagged Tklib 0.4 ======================== * 2005-05-18 Andreas Kupries * ipentry.tcl: Added missing 'require Tk'. 2005-01-09 Marty Backe * ipentry.tcl: Bug fix - widget creation was not returning the widget name. 2003-08-02 Aaron Faupell * ipentry.tcl: added highlightcolor, highlightbackground, highlightthickness options * ipentry.man: added docs for above, as well as disabledforeground, readonlybackground 2003-07-23 Aaron Faupell * initial import tcltk2/inst/tklibs/cmdline1.5.3/0000755000176200001440000000000015017041713015721 5ustar liggesuserstcltk2/inst/tklibs/cmdline1.5.3/cmdline.man0000644000176200001440000002002315017041713020026 0ustar liggesusers[vset VERSION 1.5.3] [manpage_begin cmdline n [vset VERSION]] [keywords {argument processing}] [keywords argv] [keywords argv0] [keywords {cmdline processing}] [keywords {command line processing}] [moddesc {Command line and option processing}] [titledesc {Procedures to process command lines and options.}] [category {Programming tools}] [require Tcl "8.5 9"] [require cmdline [opt [vset VERSION]]] [description] This package provides commands to parse command lines and options. [section {::argv handling}] One of the most common variables this package will be used with is [var ::argv], which holds the command line of the current application. This variable has a companion [var ::argc] which is initialized to the number of elements in [var ::argv] at the beginning of the application. [para] The commands in this package will [emph not] modify the [var ::argc] companion when called with [var ::argv]. Keeping the value consistent, if such is desired or required, is the responsibility of the caller. [section API] [list_begin definitions] [call [cmd ::cmdline::getopt] [arg argvVar] [arg optstring] [arg optVar] [arg valVar]] This command works in a fashion like the standard C based [cmd getopt] function. Given an option string and a pointer to an array of args this command will process the [strong {first argument}] and return info on how to proceed. The command returns 1 if an option was found, 0 if no more options were found, and -1 if an error occurred. [para] [arg argvVar] contains the name of the list of arguments to process. If options are found the list is modified and the processed arguments are removed from the start of the list. [para] [arg optstring] contains a list of command options that the application will accept. If the option ends in ".arg" the command will use the next argument as an argument to the option, or extract it from the current argument, if it is of the form "option=value". Otherwise the option is a boolean that is set to 1 if present. [para] [arg optVar] refers to the variable the command will store the found option into (without the leading '-' and without the .arg extension). [para] [arg valVar] refers to the variable to store either the value for the specified option into upon success or an error message in the case of failure. The stored value comes from the command line for .arg options, otherwise the value is 1. [call [cmd ::cmdline::getKnownOpt] [arg argvVar] [arg optstring] [arg optVar] [arg valVar]] Like [cmd ::cmdline::getopt], except it ignores any unknown options in the input. [call [cmd ::cmdline::getoptions] [arg argvVar] [arg optlist] [opt [arg usage]]] Processes the entire set of command line options found in the list variable named by [arg argvVar] and fills in defaults for those not specified. This also generates an error message that lists the allowed flags if an incorrect flag is specified. The optional [arg usage]-argument contains a string to include in front of the generated message. If not present it defaults to "options:". [para] [arg argvVar] contains the name of the list of arguments to process. If options are found the list is modified and the processed arguments are removed from the start of the list. [para] [arg optlist] contains a list of lists where each element specifies an option in the form: [arg flag] [arg default] [arg comment]. [para] If [arg flag] ends in ".arg" then the value is taken from the command line. Otherwise it is a boolean and appears in the result if present on the command line. If [arg flag] ends in ".secret", it will not be displayed in the usage. [para] The options [option -?], [option -help], and [option --] are implicitly understood. The first two abort option processing by throwing an error and force the generation of the usage message, whereas the the last aborts option processing without an error, leaving all arguments coming after for regular processing, even if starting with a dash. [para] The result of the command is a dictionary mapping all options to their values, be they user-specified or defaults. [call [cmd ::cmdline::getKnownOptions] [arg argvVar] [arg optlist] [opt [arg usage]]] Like [cmd ::cmdline::getoptions], but ignores any unknown options in the input. [call [cmd ::cmdline::usage] [arg optlist] [opt [arg usage]]] Generates and returns an error message that lists the allowed flags. [arg optlist] is defined as for [cmd ::cmdline::getoptions]. The optional [arg usage]-argument contains a string to include in front of the generated message. If not present it defaults to "options:". [call [cmd ::cmdline::getfiles] [arg patterns] [arg quiet]] Given a list of file [arg patterns] this command computes the set of valid files. On windows, file globbing is performed on each argument. On Unix, only file existence is tested. If a file argument produces no valid files, a warning is optionally generated (set [arg quiet] to true). [para] This code also uses the full path for each file. If not given it prepends the current working directory to the filename. This ensures that these files will never conflict with files in a wrapped zip file. The last sentence refers to the pro-tools. [call [cmd ::cmdline::getArgv0]] This command returns the "sanitized" version of [arg argv0]. It will strip off the leading path and removes the extension ".bin". The latter is used by the TclPro applications because they must be wrapped by a shell script. [list_end] [subsection {Error Codes}] Starting with version 1.5 all errors thrown by the package have a proper [var ::errorCode] for use with Tcl's [cmd try] command. This code always has the word [const CMDLINE] as its first element. [section EXAMPLES] [subsection cmdline::getoptions] This example, taken from the package [package fileutil] and slightly modified, demonstrates how to use [cmd cmdline::getoptions]. First, a list of options is created, then the 'args' list is passed to cmdline for processing. Subsequently, different options are checked to see if they have been passed to the script, and what their value is. [para] [example { package require Tcl 8.5 package require try ;# Tcllib. package require cmdline 1.5 ;# First version with proper error-codes. # Notes: # - Tcl 8.6+ has 'try' as a builtin command and therefore does not # need the 'try' package. # - Before Tcl 8.5 we cannot support 'try' and have to use 'catch'. # This then requires a dedicated test (if) on the contents of # ::errorCode to separate the CMDLINE USAGE signal from actual errors. set options { {a "set the atime only"} {m "set the mtime only"} {c "do not create non-existent files"} {r.arg "" "use time from ref_file"} {t.arg -1 "use specified time"} } set usage ": MyCommandName\ \[options] filename ...\noptions:" try { array set params [::cmdline::getoptions argv $options $usage] # Note: argv is modified now. The recognized options are # removed from it, leaving the non-option arguments behind. } trap {CMDLINE USAGE} {msg o} { # Trap the usage signal, print the message, and exit the application. # Note: Other errors are not caught and passed through to higher levels! puts $msg exit 1 } if { $params(a) } { set set_atime "true" } set has_t [expr {$params(t) != -1}] set has_r [expr {[string length $params(r)] > 0}] if {$has_t && $has_r} { return -code error "Cannot specify both -r and -t" } elseif {$has_t} { ... } }] [subsection cmdline::getopt] This example shows the core loop of [cmd cmdline::getoptions] from the previous example. It demonstrates how it uses [cmd cmdline::get] to process the options one at a time. [example { while {[set err [getopt argv $opts opt arg]]} { if {$err < 0} { set result(?) "" break } set result($opt) $arg } }] [vset CATEGORY cmdline] [include ../common-text/feedback.inc] [manpage_end] tcltk2/inst/tklibs/cmdline1.5.3/cmdline.tcl0000644000176200001440000007462215017041713020053 0ustar liggesusers# cmdline.tcl -- # # This package provides a utility for parsing command line # arguments that are processed by our various applications. # It also includes a utility routine to determine the # application name for use in command line errors. # # Copyright (c) 1998-2000 by Ajuba Solutions. # Copyright (c) 2001-2015 by Andreas Kupries . # Copyright (c) 2003 by David N. Welton # 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 9 package provide cmdline 1.5.3 namespace eval ::cmdline { namespace export getArgv0 getopt getKnownOpt getfiles getoptions \ getKnownOptions usage } # ::cmdline::getopt -- # # The cmdline::getopt works in a fashion like the standard # C based getopt function. Given an option string and a # pointer to an array or args this command will process the # first argument and return info on how to proceed. # # Arguments: # argvVar Name of the argv list that you # want to process. If options are found the # arg list is modified and the processed arguments # are removed from the start of the list. # optstring A list of command options that the application # will accept. If the option ends in ".arg" the # getopt routine will use the next argument as # an argument to the option. Otherwise the option # is a boolean that is set to 1 if present. # optVar The variable pointed to by optVar # contains the option that was found (without the # leading '-' and without the .arg extension). # valVar Upon success, the variable pointed to by valVar # contains the value for the specified option. # This value comes from the command line for .arg # options, otherwise the value is 1. # If getopt fails, the valVar is filled with an # error message. # # Results: # The getopt function returns 1 if an option was found, 0 if no more # options were found, and -1 if an error occurred. proc ::cmdline::getopt {argvVar optstring optVar valVar} { upvar 1 $argvVar argsList upvar 1 $optVar option upvar 1 $valVar value set result [getKnownOpt argsList $optstring option value] if {$result < 0} { # Collapse unknown-option error into any-other-error result. set result -1 } return $result } # ::cmdline::getKnownOpt -- # # The cmdline::getKnownOpt works in a fashion like the standard # C based getopt function. Given an option string and a # pointer to an array or args this command will process the # first argument and return info on how to proceed. # # Arguments: # argvVar Name of the argv list that you # want to process. If options are found the # arg list is modified and the processed arguments # are removed from the start of the list. Note that # unknown options and the args that follow them are # left in this list. # optstring A list of command options that the application # will accept. If the option ends in ".arg" the # getopt routine will use the next argument as # an argument to the option. Otherwise the option # is a boolean that is set to 1 if present. # optVar The variable pointed to by optVar # contains the option that was found (without the # leading '-' and without the .arg extension). # valVar Upon success, the variable pointed to by valVar # contains the value for the specified option. # This value comes from the command line for .arg # options, otherwise the value is 1. # If getopt fails, the valVar is filled with an # error message. # # Results: # The getKnownOpt function returns 1 if an option was found, # 0 if no more options were found, -1 if an unknown option was # encountered, and -2 if any other error occurred. proc ::cmdline::getKnownOpt {argvVar optstring optVar valVar} { upvar 1 $argvVar argsList upvar 1 $optVar option upvar 1 $valVar value # default settings for a normal return set value "" set option "" set result 0 # check if we're past the end of the args list if {[llength $argsList] != 0} { # if we got -- or an option that doesn't begin with -, return (skipping # the --). otherwise process the option arg. switch -glob -- [set arg [lindex $argsList 0]] { "--" { set argsList [lrange $argsList 1 end] } "--*" - "-*" { set option [string range $arg 1 end] if {[string equal [string range $option 0 0] "-"]} { set option [string range $arg 2 end] } # support for format: [-]-option=value set idx [string first "=" $option 1] if {$idx != -1} { set _val [string range $option [expr {$idx+1}] end] set option [string range $option 0 [expr {$idx-1}]] } if {[lsearch -exact $optstring $option] != -1} { # Booleans are set to 1 when present set value 1 set result 1 set argsList [lrange $argsList 1 end] } elseif {[lsearch -exact $optstring "$option.arg"] != -1} { set result 1 set argsList [lrange $argsList 1 end] if {[info exists _val]} { set value $_val } elseif {[llength $argsList]} { set value [lindex $argsList 0] set argsList [lrange $argsList 1 end] } else { set value "Option \"$option\" requires an argument" set result -2 } } else { # Unknown option. set value "Illegal option \"-$option\"" set result -1 } } default { # Skip ahead } } } return $result } # ::cmdline::getoptions -- # # Process a set of command line options, filling in defaults # for those not specified. This also generates an error message # that lists the allowed flags if an incorrect flag is specified. # # Arguments: # argvVar The name of the argument list, typically argv. # We remove all known options and their args from it. # In other words, after the call to this command the # referenced variable contains only the non-options, # and unknown options. # optlist A list-of-lists where each element specifies an option # in the form: # (where flag takes no argument) # flag comment # # (or where flag takes an argument) # flag default comment # # If flag ends in ".arg" then the value is taken from the # command line. Otherwise it is a boolean and appears in # the result if present on the command line. If flag ends # in ".secret", it will not be displayed in the usage. # usage Text to include in the usage display. Defaults to # "options:" # # Results # Name value pairs suitable for using with array set. # A modified `argvVar`. proc ::cmdline::getoptions {argvVar optlist {usage options:}} { upvar 1 $argvVar argv set opts [GetOptionDefaults $optlist result] set argc [llength $argv] while {[set err [getopt argv $opts opt arg]]} { if {$err < 0} { set result(?) "" break } set result($opt) $arg } if {[info exist result(?)] || [info exists result(help)]} { Error [usage $optlist $usage] USAGE } return [array get result] } # ::cmdline::getKnownOptions -- # # Process a set of command line options, filling in defaults # for those not specified. This ignores unknown flags, but generates # an error message that lists the correct usage if a known option # is used incorrectly. # # Arguments: # argvVar The name of the argument list, typically argv. This # We remove all known options and their args from it. # In other words, after the call to this command the # referenced variable contains only the non-options, # and unknown options. # optlist A list-of-lists where each element specifies an option # in the form: # flag default comment # If flag ends in ".arg" then the value is taken from the # command line. Otherwise it is a boolean and appears in # the result if present on the command line. If flag ends # in ".secret", it will not be displayed in the usage. # usage Text to include in the usage display. Defaults to # "options:" # # Results # Name value pairs suitable for using with array set. # A modified `argvVar`. proc ::cmdline::getKnownOptions {argvVar optlist {usage options:}} { upvar 1 $argvVar argv set opts [GetOptionDefaults $optlist result] # As we encounter them, keep the unknown options and their # arguments in this list. Before we return from this procedure, # we'll prepend these args to the argList so that the application # doesn't lose them. set unknownOptions [list] set argc [llength $argv] while {[set err [getKnownOpt argv $opts opt arg]]} { if {$err == -1} { # Unknown option. # Skip over any non-option items that follow it. # For now, add them to the list of unknownOptions. lappend unknownOptions [lindex $argv 0] set argv [lrange $argv 1 end] while {([llength $argv] != 0) \ && ![string match "-*" [lindex $argv 0]]} { lappend unknownOptions [lindex $argv 0] set argv [lrange $argv 1 end] } } elseif {$err == -2} { set result(?) "" break } else { set result($opt) $arg } } # Before returning, prepend the any unknown args back onto the # argList so that the application doesn't lose them. set argv [concat $unknownOptions $argv] if {[info exist result(?)] || [info exists result(help)]} { Error [usage $optlist $usage] USAGE } return [array get result] } # ::cmdline::GetOptionDefaults -- # # This internal procedure processes the option list (that was passed to # the getopt or getKnownOpt procedure). The defaultArray gets an index # for each option in the option list, the value of which is the option's # default value. # # Arguments: # optlist A list-of-lists where each element specifies an option # in the form: # flag default comment # If flag ends in ".arg" then the value is taken from the # command line. Otherwise it is a boolean and appears in # the result if present on the command line. If flag ends # in ".secret", it will not be displayed in the usage. # defaultArrayVar The name of the array in which to put argument defaults. # # Results # Name value pairs suitable for using with array set. proc ::cmdline::GetOptionDefaults {optlist defaultArrayVar} { upvar 1 $defaultArrayVar result set opts {? help} foreach opt $optlist { set name [lindex $opt 0] if {[regsub -- {\.secret$} $name {} name] == 1} { # Need to hide this from the usage display and getopt } lappend opts $name if {[regsub -- {\.arg$} $name {} name] == 1} { # Set defaults for those that take values. set default [lindex $opt 1] set result($name) $default } else { # The default for booleans is false set result($name) 0 } } return $opts } # ::cmdline::usage -- # # Generate an error message that lists the allowed flags. # # Arguments: # optlist As for cmdline::getoptions # usage Text to include in the usage display. Defaults to # "options:" # # Results # A formatted usage message proc ::cmdline::usage {optlist {usage {options:}}} { set str "[getArgv0] $usage\n" set longest 20 set lines {} foreach opt [concat $optlist \ {{- "Forcibly stop option processing"} {help "Print this message"} {? "Print this message"}}] { set name "-[lindex $opt 0]" if {[regsub -- {\.secret$} $name {} name] == 1} { # Hidden option continue } if {[regsub -- {\.arg$} $name {} name] == 1} { append name " value" set desc "[lindex $opt 2] <[lindex $opt 1]>" } else { set desc "[lindex $opt 1]" } set n [string length $name] if {$n > $longest} { set longest $n } # max not available before 8.5 - set longest [expr {max($longest, )}] lappend lines $name $desc } foreach {name desc} $lines { append str "[string trimright [format " %-*s %s" $longest $name $desc]]\n" } return $str } # ::cmdline::getfiles -- # # Given a list of file arguments from the command line, compute # the set of valid files. On windows, file globbing is performed # on each argument. On Unix, only file existence is tested. If # a file argument produces no valid files, a warning is optionally # generated. # # This code also uses the full path for each file. If not # given it prepends [pwd] to the filename. This ensures that # these files will never conflict with files in our zip file. # # Arguments: # patterns The file patterns specified by the user. # quiet If this flag is set, no warnings will be generated. # # Results: # Returns the list of files that match the input patterns. proc ::cmdline::getfiles {patterns quiet} { set result {} if {$::tcl_platform(platform) == "windows"} { foreach pattern $patterns { set pat [file join $pattern] set files [glob -nocomplain -- $pat] if {$files == {}} { if {! $quiet} { puts stdout "warning: no files match \"$pattern\"" } } else { foreach file $files { lappend result $file } } } } else { set result $patterns } set files {} foreach file $result { # Make file an absolute path so that we will never conflict # with files that might be contained in our zip file. set fullPath [file join [pwd] $file] if {[file isfile $fullPath]} { lappend files $fullPath } elseif {! $quiet} { puts stdout "warning: no files match \"$file\"" } } return $files } # ::cmdline::getArgv0 -- # # This command returns the "sanitized" version of argv0. It will strip # off the leading path and remove the ".bin" extensions that our apps # use because they must be wrapped by a shell script. # # Arguments: # None. # # Results: # The application name that can be used in error messages. proc ::cmdline::getArgv0 {} { global argv0 set name [file tail $argv0] return [file rootname $name] } ## # ### ### ### ######### ######### ######### ## # Now the typed versions of the above commands. ## # ### ### ### ######### ######### ######### ## # typedCmdline.tcl -- # # This package provides a utility for parsing typed command # line arguments that may be processed by various applications. # # Copyright (c) 2000 by Ross Palmer Mohn. # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: cmdline.tcl,v 1.28 2011/02/23 17:41:52 andreas_kupries Exp $ namespace eval ::cmdline { namespace export typedGetopt typedGetoptions typedUsage # variable cmdline::charclasses -- # # Create regexp list of allowable character classes # from "string is" error message. # # Results: # String of character class names separated by "|" characters. variable charclasses #checker exclude badKey catch {string is . .} charclasses variable dummy regexp -- {must be (.+)$} $charclasses dummy charclasses regsub -all -- {, (or )?} $charclasses {|} charclasses unset dummy } # ::cmdline::typedGetopt -- # # The cmdline::typedGetopt works in a fashion like the standard # C based getopt function. Given an option string and a # pointer to a list of args this command will process the # first argument and return info on how to proceed. In addition, # you may specify a type for the argument to each option. # # Arguments: # argvVar Name of the argv list that you want to process. # If options are found, the arg list is modified # and the processed arguments are removed from the # start of the list. # # optstring A list of command options that the application # will accept. If the option ends in ".xxx", where # xxx is any valid character class to the tcl # command "string is", then typedGetopt routine will # use the next argument as a typed argument to the # option. The argument must match the specified # character classes (e.g. integer, double, boolean, # xdigit, etc.). Alternatively, you may specify # ".arg" for an untyped argument. # # optVar Upon success, the variable pointed to by optVar # contains the option that was found (without the # leading '-' and without the .xxx extension). If # typedGetopt fails the variable is set to the empty # string. SOMETIMES! Different for each -value! # # argVar Upon success, the variable pointed to by argVar # contains the argument for the specified option. # If typedGetopt fails, the variable is filled with # an error message. # # Argument type syntax: # Option that takes no argument. # foo # # Option that takes a typeless argument. # foo.arg # # Option that takes a typed argument. Allowable types are all # valid character classes to the tcl command "string is". # Currently must be one of alnum, alpha, ascii, control, # boolean, digit, double, false, graph, integer, lower, print, # punct, space, true, upper, wordchar, or xdigit. # foo.double # # Option that takes an argument from a list. # foo.(bar|blat) # # Argument quantifier syntax: # Option that takes an optional argument. # foo.arg? # # Option that takes a list of arguments terminated by "--". # foo.arg+ # # Option that takes an optional list of arguments terminated by "--". # foo.arg* # # Argument quantifiers work on all argument types, so, for # example, the following is a valid option specification. # foo.(bar|blat|blah)? # # Argument syntax miscellany: # Options may be specified on the command line using a unique, # shortened version of the option name. Given that program foo # has an option list of {bar.alpha blah.arg blat.double}, # "foo -b fob" returns an error, but "foo -ba fob" # successfully returns {bar fob} # # Results: # The typedGetopt function returns one of the following: # 1 a valid option was found # 0 no more options found to process # -1 invalid option # -2 missing argument to a valid option # -3 argument to a valid option does not match type # # Known Bugs: # When using options which include special glob characters, # you must use the exact option. Abbreviating it can cause # an error in the "cmdline::prefixSearch" procedure. proc ::cmdline::typedGetopt {argvVar optstring optVar argVar} { variable charclasses upvar $argvVar argsList upvar $optVar retvar upvar $argVar optarg # default settings for a normal return set optarg "" set retvar "" set retval 0 # check if we're past the end of the args list if {[llength $argsList] != 0} { # if we got -- or an option that doesn't begin with -, return (skipping # the --). otherwise process the option arg. switch -glob -- [set arg [lindex $argsList 0]] { "--" { set argsList [lrange $argsList 1 end] } "-*" { # Create list of options without their argument extensions set optstr "" foreach str $optstring { lappend optstr [file rootname $str] } set _opt [string range $arg 1 end] set i [prefixSearch $optstr [file rootname $_opt]] if {$i != -1} { set opt [lindex $optstring $i] set quantifier "none" if {[regexp -- {\.[^.]+([?+*])$} $opt dummy quantifier]} { set opt [string range $opt 0 end-1] } if {[string first . $opt] == -1} { set retval 1 set retvar $opt set argsList [lrange $argsList 1 end] } elseif {[regexp -- "\\.(arg|$charclasses)\$" $opt dummy charclass] || [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} { if {[string equal arg $charclass]} { set type arg } elseif {[regexp -- "^($charclasses)\$" $charclass]} { set type class } else { set type oneof } set argsList [lrange $argsList 1 end] set opt [file rootname $opt] while {1} { if {[llength $argsList] == 0 || [string equal "--" [lindex $argsList 0]]} { if {[string equal "--" [lindex $argsList 0]]} { set argsList [lrange $argsList 1 end] } set oneof "" if {$type == "arg"} { set charclass an } elseif {$type == "oneof"} { set oneof ", one of $charclass" set charclass an } if {$quantifier == "?"} { set retval 1 set retvar $opt set optarg "" } elseif {$quantifier == "+"} { set retvar $opt if {[llength $optarg] < 1} { set retval -2 set optarg "Option requires at least one $charclass argument$oneof -- $opt" } else { set retval 1 } } elseif {$quantifier == "*"} { set retval 1 set retvar $opt } else { set optarg "Option requires $charclass argument$oneof -- $opt" set retvar $opt set retval -2 } set quantifier "" } elseif {($type == "arg") || (($type == "oneof") && [string first "|[lindex $argsList 0]|" "|$charclass|"] != -1) || (($type == "class") && [string is $charclass [lindex $argsList 0]])} { set retval 1 set retvar $opt lappend optarg [lindex $argsList 0] set argsList [lrange $argsList 1 end] } else { set oneof "" if {$type == "arg"} { set charclass an } elseif {$type == "oneof"} { set oneof ", one of $charclass" set charclass an } set optarg "Option requires $charclass argument$oneof -- $opt" set retvar $opt set retval -3 if {$quantifier == "?"} { set retval 1 set optarg "" } set quantifier "" } if {![regexp -- {[+*]} $quantifier]} { break; } } } else { Error \ "Illegal option type specification: must be one of $charclasses" \ BAD OPTION TYPE } } else { set optarg "Illegal option -- $_opt" set retvar $_opt set retval -1 } } default { # Skip ahead } } } return $retval } # ::cmdline::typedGetoptions -- # # Process a set of command line options, filling in defaults # for those not specified. This also generates an error message # that lists the allowed options if an incorrect option is # specified. # # Arguments: # argvVar The name of the argument list, typically argv # optlist A list-of-lists where each element specifies an option # in the form: # # option default comment # # Options formatting is as described for the optstring # argument of typedGetopt. Default is for optionally # specifying a default value. Comment is for optionally # specifying a comment for the usage display. The # options "--", "-help", and "-?" are automatically included # in optlist. # # Argument syntax miscellany: # Options formatting and syntax is as described in typedGetopt. # There are two additional suffixes that may be applied when # passing options to typedGetoptions. # # You may add ".multi" as a suffix to any option. For options # that take an argument, this means that the option may be used # more than once on the command line and that each additional # argument will be appended to a list, which is then returned # to the application. # foo.double.multi # # If a non-argument option is specified as ".multi", it is # toggled on and off for each time it is used on the command # line. # foo.multi # # If an option specification does not contain the ".multi" # suffix, it is not an error to use an option more than once. # In this case, the behavior for options with arguments is that # the last argument is the one that will be returned. For # options that do not take arguments, using them more than once # has no additional effect. # # Options may also be hidden from the usage display by # appending the suffix ".secret" to any option specification. # Please note that the ".secret" suffix must be the last suffix, # after any argument type specification and ".multi" suffix. # foo.xdigit.multi.secret # # Results # Name value pairs suitable for using with array set. proc ::cmdline::typedGetoptions {argvVar optlist {usage options:}} { variable charclasses upvar 1 $argvVar argv set opts {? help} foreach opt $optlist { set name [lindex $opt 0] if {[regsub -- {\.secret$} $name {} name] == 1} { # Remove this extension before passing to typedGetopt. } if {[regsub -- {\.multi$} $name {} name] == 1} { # Remove this extension before passing to typedGetopt. regsub -- {\..*$} $name {} temp set multi($temp) 1 } lappend opts $name if {[regsub -- "\\.(arg|$charclasses|\\(.+).?\$" $name {} name] == 1} { # Set defaults for those that take values. # Booleans are set just by being present, or not set dflt [lindex $opt 1] if {$dflt != {}} { set defaults($name) $dflt } } } set argc [llength $argv] while {[set err [typedGetopt argv $opts opt arg]]} { if {$err == 1} { if {[info exists result($opt)] && [info exists multi($opt)]} { # Toggle boolean options or append new arguments if {$arg == ""} { unset result($opt) } else { set result($opt) "$result($opt) $arg" } } else { set result($opt) "$arg" } } elseif {($err == -1) || ($err == -3)} { Error [typedUsage $optlist $usage] USAGE } elseif {$err == -2 && ![info exists defaults($opt)]} { Error [typedUsage $optlist $usage] USAGE } } if {[info exists result(?)] || [info exists result(help)]} { Error [typedUsage $optlist $usage] USAGE } foreach {opt dflt} [array get defaults] { if {![info exists result($opt)]} { set result($opt) $dflt } } return [array get result] } # ::cmdline::typedUsage -- # # Generate an error message that lists the allowed flags, # type of argument taken (if any), default value (if any), # and an optional description. # # Arguments: # optlist As for cmdline::typedGetoptions # # Results # A formatted usage message proc ::cmdline::typedUsage {optlist {usage {options:}}} { variable charclasses set str "[getArgv0] $usage\n" set longest 20 set lines {} foreach opt [concat $optlist \ {{help "Print this message"} {? "Print this message"}}] { set name "-[lindex $opt 0]" if {[regsub -- {\.secret$} $name {} name] == 1} { # Hidden option continue } if {[regsub -- {\.multi$} $name {} name] == 1} { # Display something about multiple options } if {[regexp -- "\\.(arg|$charclasses)\$" $name dummy charclass] || [regexp -- {\.\(([^)]+)\)} $opt dummy charclass] } { regsub -- "\\..+\$" $name {} name append name " $charclass" set desc [lindex $opt 2] set default [lindex $opt 1] if {$default != ""} { append desc " <$default>" } } else { set desc [lindex $opt 1] } lappend accum $name $desc set n [string length $name] if {$n > $longest} { set longest $n } # max not available before 8.5 - set longest [expr {max($longest, [string length $name])}] } foreach {name desc} $accum { append str "[string trimright [format " %-*s %s" $longest $name $desc]]\n" } return $str } # ::cmdline::prefixSearch -- # # Search a Tcl list for a pattern; searches first for an exact match, # and if that fails, for a unique prefix that matches the pattern # (i.e, first "lsearch -exact", then "lsearch -glob $pattern*" # # Arguments: # list list of words # pattern word to search for # # Results: # Index of found word is returned. If no exact match or # unique short version is found then -1 is returned. proc ::cmdline::prefixSearch {list pattern} { # Check for an exact match if {[set pos [::lsearch -exact $list $pattern]] > -1} { return $pos } # Check for a unique short version set slist [lsort $list] if {[set pos [::lsearch -glob $slist $pattern*]] > -1} { # What if there is nothing for the check variable? set check [lindex $slist [expr {$pos + 1}]] if {[string first $pattern $check] != 0} { return [::lsearch -exact $list [lindex $slist $pos]] } } return -1 } # ::cmdline::Error -- # # Internal helper to throw errors with a proper error-code attached. # # Arguments: # message text of the error message to throw. # args additional parts of the error code to use, # with CMDLINE as basic prefix added by this command. # # Results: # An error is thrown, always. proc ::cmdline::Error {message args} { return -code error -errorcode [linsert $args 0 CMDLINE] $message } tcltk2/inst/tklibs/cmdline1.5.3/pkgIndex.tcl0000644000176200001440000000021215017041713020171 0ustar liggesusersif {![package vsatisfies [package provide Tcl] 8.5 9]} {return} package ifneeded cmdline 1.5.3 [list source [file join $dir cmdline.tcl]] tcltk2/inst/tklibs/cmdline1.5.3/ChangeLog0000644000176200001440000002533615017041713017504 0ustar liggesusers2013-02-01 Andreas Kupries * * Released and tagged Tcllib 1.15 ======================== * 2013-01-08 Andreas Kupries * typedCmdline.test: Fixed test results of typed-cmdline-6.14 for Tcl 8.6 and higher. Rewritten to use constraints properly instead of via conditional execution. 2011-12-13 Andreas Kupries * * Released and tagged Tcllib 1.14 ======================== * 2011-02-23 Andreas Kupries * cmdline.man: [Bug 3189786]: Fixed mishandling of suffixes .arg * cmdline.tcl: and .secret. The '.'s were not properly quoted, * cmdline.test: allowing any character, thus mishandling options * pkgIndex.tcl: like 'myarg' or 'mysecret'. Extended the testsuite. Bumped version to 1.3.3. 2011-01-24 Andreas Kupries * * Released and tagged Tcllib 1.13 ======================== * 2010-09-08 Andreas Kupries * cmdline.man: [Bug 3041989]: Added the missing documentation for * cmdline.tcl: the result of command 'getoptions'. Documented the * cmdline.test: handling of the implicit options -?, -help, and * pkgIndex.tcl: --. Added help text for option '--'. Bumped to version 1.3.2. 2010-05-27 Andreas Kupries * cmdline.man: [Bug 2988486]: Added a note about ::argv handling to the documentation, i.e. us not keeping ::argc synchronized. 2010-03-10 Elchonon Edelson * cmdline.man: Fixed typo. 2009-12-07 Andreas Kupries * * Released and tagged Tcllib 1.12 ======================== * 2008-12-12 Andreas Kupries * * Released and tagged Tcllib 1.11.1 ======================== * 2008-10-16 Andreas Kupries * * Released and tagged Tcllib 1.11 ======================== * 2008-07-09 Andreas Kupries * cmdline.tcl: Fixed problem of creative writing to variable * cmdline.man: 'dummy' in package initialization code by defining * pkgIndex.tcl: the variable in the namespace for the time it is needed. This fixes the [Bug 2014325]. Version bumped to 1.3.1. 2008-06-14 Andreas Kupries * cmdline.pcx: New file. Syntax definitions for the public commands of the cmdline package. 2008-03-25 Andreas Kupries * cmdline.tcl: Added pragma forcing the tclchecker to ignore an intentional and caught badKey problem used to introspect the runtime. 2007-09-12 Andreas Kupries * * Released and tagged Tcllib 1.10 ======================== * 2007-08-02 Andreas Kupries * typedCmdline.test: Updated to changes in Tcl 8.5 head. 2007-03-19 Andreas Kupries * cmdline.man: Fixed all warnings due to use of now deprecated commands. Added a section about how to give feedback. 2007-01-11 Andreas Kupries * cmdline.man: Extended the list of keywords in the documentation. [SF Tcllib Bug 1615252]. 2006-10-03 Andreas Kupries * * Released and tagged Tcllib 1.9 ======================== * 2006-09-27 Andreas Kupries * cmdline.tcl: Bumped to version 1.3, due internal rewrite * cmdline.man: (Folding of typedCmdline into main file). * pkgIndex.tcl: 2006-09-13 Andreas Kupries * cmdline.test: Added 'exit' to the scripts executed in sub-shells, to make them usable with 'wish'-type shells as well. 2006-04-05 Andreas Kupries * cmdline.tcl: Added the contents of typedCmdline.tcl to this file (appended). It was loaded anyway, always, its procedures used the same namespace, a separation does not make much sense. It also makes deployment of the package as Tcl Module trivial, i.e. this squashes the need to use some virtual filesystem to keep everything together. * typedCmdline.tcl: File removed. Contents appended to cmdline.tcl, s.a. 2006-01-28 Andreas Kupries * cmdline.test: Fixed use and cleanup of temp. files. * typedCmdline.test: Fixed use of duplicate test names. 2006-01-22 Andreas Kupries * cmdline.test: More boilerplate simplified via use of test support. * typedCmdline.test: 2006-01-21 Andreas Kupries * typedCmdline.test: Replaced usage of the made-up command 'queryConstraint' with 'testConstraint'. 2006-01-19 Andreas Kupries * typedCmdline.test: Hooked into the new common test support * cmdline.test: code. 2005-10-06 Andreas Kupries * * Released and tagged Tcllib 1.8 ======================== * 2004-11-08 Andreas Kupries * cmdline.tcl (::cmdline::getKnownOpt): Changed generation of error message for unknown option, re-added the prefix-dash to the option name. See AS Bugzilla Report 32363 [http://bugs.activestate.com/show_bug.cgi?id=32363]. * cmdline.test: Updated testsuite to new error message. 2004-10-05 Andreas Kupries * * Released and tagged Tcllib 1.7 ======================== * 2004-08-25 Andreas Kupries * typedCmdline.test: Made test 6.14 conditional on version of Tcl, needs different result for 8.5+. 2004-08-16 Andreas Kupries * ChangeLog: Typo police. * cmdline.tcl: * cmdline.man: * typedCmdline.tcl: 2004-05-23 Andreas Kupries * * Released and tagged Tcllib 1.6.1 ======================== * 2004-02-15 Andreas Kupries * * Released and tagged Tcllib 1.6 ======================== * 2004-02-09 Andreas Kupries * typedCmdline.test: Fixed the problems of the testsuite with * cmdline.test: Tcl 8.5. It relied on the order of data returned by [array get]. 2003-08-19 David N. Welton * cmdline.man: Added an example. Feel free to change/improve it, but this package really needed one to show the standard usage pattern. 2003-08-07 Andreas Kupries * Bumped version information to 1.2.2 for the bugfix. 2003-08-06 Andreas Kupries * cmdline.tcl (getfiles): Using the [string map] fix still had problems, when mixing back- and forward slashes. Now using [file join] on the pattern. This removed all problems with the quoting. I.e. this operation pseudo-normalizes the path. Got the trick from Jeff Hobbs. 2003-08-06 Andreas Kupries * cmdline.test: Added a test for the backslash quoting behaviour. * cmdline.tcl (getfiles): Corrected a bogus attempt to quote backslashes in file patterns on the windows platform. 2003-05-05 Andreas Kupries * * Released and tagged Tcllib 1.4 ======================== * 2003-04-11 Andreas Kupries * typedCmdline.tcl: Fixed bug #614591. See also last entry, this file was forgotten. 2003-04-10 Andreas Kupries * pkgIndex.tcl: * cmdline.tcl: * cmdline.man: Fixed bug #648679. Fixed bug #614591. Set version of the package to to 1.2.1 * urn-scheme.tcl: Fixed bug #614591. Set version of the package to to 1.2.1 2003-02-23 David N. Welton * cmdline.tcl (cmdline::getfiles): Use [string map] instead of [regsub]. 2002-08-30 Andreas Kupries * typeCmdline.tcl: Updated 'info exist' to 'info exists'. 2002-04-24 Andreas Kupries * Applied patch #540313 on behalf of Melissa Chawla and Don Porter . * cmdline.test: * cmdline.tcl: Added getKnownOpt and getKnownOptions procedures to the API. The procedures offer a way for arguments that are not in the optionList to be ignored. This way, you can have two independent locations in your application where command line arguments are parsed. I bumped the package version to 1.2. * cmdline.man: Updated documentation. 2002-04-14 Andreas Kupries * cmdline.man: Added doctools manpage. 2001-10-16 Andreas Kupries * cmdline.n: * cmdline.tcl: * pkgIndex.tcl: Version up to 1.1.1 2001-10-12 Andreas Kupries * cmdline.tcl: Corrected the inline documentation to reflect what is actually happening. Problem reported by Glenn Jackman , Item #46650. 2001-07-31 Andreas Kupries * cmdline.n: Added manpage [446584]. 2001-06-21 Andreas Kupries * typedCmdline.tcl: * cmdline.tcl: Fixed dubious code reported by frink. 2000-05-03 Brent Welch * cmdline.tcl: Changed cmdline::getopt to set boolean arguments to 0 or 1 explicitly. Previously it just set the value to "" if it was present, or did nothing. This fixes the -verbose command line bug in connect. 2000-04-07 Eric Melski * typedCmdline.test: Changed sourcing bits at start of file to work better with updated file dependencies. * typedCmdline.tcl: Removed "package provide"; that should occur only in one file per package. Reformatted function headers to comply with Tcl coding standard. Renamed "cmdline::lsearch" to "cmdline::prefixSearch" to avoid confusion, and removed code thus made obsolete. * cmdline.tcl: Added call to source typedCmdline.tcl 2000-04-04 Ross Mohn * typedCmdline.tcl: Added typed versions of getopt, getoptions, and usage. Types supported are all character classes available for the Tcl "string in" command. * typedCmdline.test: Added tests for typed procedures. * cmdline.tcl: Corrected some documentation errors and omissions. 2000-03-09 Eric Melski * cmdline.test: Adapted tests to work with tcllib test framework. 1999-10-29 Scott Stanton * cmdline.tcl: Fixed bug where options that contained regexp special characters would cause an error. Cleaned up lots of messy code. Added test suite. tcltk2/inst/tklibs/cmdline1.5.3/typedCmdline.test0000644000176200001440000004763615017041713021263 0ustar liggesusers# -*- tcl -*-# This file contains the tests for the typedCmdline.tcl file. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 2000 by Ross Palmer Mohn. # All rights reserved. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal cmdline.tcl cmdline } # ------------------------------------------------------------------------- set argv0 "argv0" # --------------------------------------------------- # cmdline::typedGetopt test typed-cmdline-6.1 {cmdline::typedGetopt} { catch {unset opt} catch {unset arg} set argList {} list [cmdline::typedGetopt argList {a} opt arg] $argList $opt $arg } {0 {} {} {}} test typed-cmdline-6.2 {cmdline::typedGetopt, multiple options} { catch {unset opt} catch {unset arg} set argList {} list [cmdline::typedGetopt argList {a b.arg c} opt arg] $argList $opt $arg } {0 {} {} {}} test typed-cmdline-6.3 {cmdline::typedGetopt, -- option} { catch {unset opt} catch {unset arg} set argList {-- -a} list [cmdline::typedGetopt argList {a} opt arg] $argList $opt $arg } {0 -a {} {}} test typed-cmdline-6.4 {cmdline::typedGetopt, non dash option} { catch {unset opt} catch {unset arg} set argList {b -a} list [cmdline::typedGetopt argList {a} opt arg] $argList $opt $arg } {0 {b -a} {} {}} test typed-cmdline-6.5 {cmdline::typedGetopt, simple option} { catch {unset opt} catch {unset arg} set argList {-a b} list [cmdline::typedGetopt argList {a} opt arg] $argList $opt $arg } {1 b a {}} test typed-cmdline-6.6 {cmdline::typedGetopt, multiple letter option} { catch {unset opt} catch {unset arg} set argList {-foo b} list [cmdline::typedGetopt argList {foo} opt arg] $argList $opt $arg } {1 b foo {}} test typed-cmdline-6.7 {cmdline::typedGetopt, multiple letter option, abbreviation} { catch {unset opt} catch {unset arg} set argList {-f -b} list [cmdline::typedGetopt argList {foo b} opt arg] $argList $opt $arg } {1 -b foo {}} test typed-cmdline-6.8 {cmdline::typedGetopt, option with argument} { catch {unset opt} catch {unset arg} set argList {-foo bar baz} list [cmdline::typedGetopt argList {foo.arg} opt arg] $argList $opt $arg } {1 baz foo bar} test typed-cmdline-6.9 {cmdline::typedGetopt, option with argument, missing arg} { catch {unset opt} catch {unset arg} set argList {-foo} list [cmdline::typedGetopt argList {foo.arg} opt arg] $argList $opt $arg } {-2 {} foo {Option requires an argument -- foo}} test typed-cmdline-6.10 {cmdline::typedGetopt, multiple options} { catch {unset opt} catch {unset arg} set argList {-foo} list [cmdline::typedGetopt argList {a.arg b foo c.arg} opt arg] $argList $opt $arg } {1 {} foo {}} test typed-cmdline-6.11 {cmdline::typedGetopt, unusual options} { catch {unset opt} catch {unset arg} set argList {-* foo} list [cmdline::typedGetopt argList {a.arg b *.arg c.arg} opt arg] $argList $opt $arg } {1 {} * foo} test typed-cmdline-6.12 {cmdline::typedGetopt, integer options} { catch {unset opt} catch {unset arg} set argList {-foo -a bar} list [cmdline::typedGetopt argList {a.arg foo.integer b} opt arg] $argList $opt $arg } {-3 {-a bar} foo {Option requires integer argument -- foo}} test typed-cmdline-6.13 {cmdline::typedGetopt, integer options} { catch {unset opt} catch {unset arg} set argList {-foo 123} list [cmdline::typedGetopt argList {a.arg foo.integer b} opt arg] $argList $opt $arg } {1 {} foo 123} test typed-cmdline-6.14.0 {cmdline::typedGetopt, integer options} tcl8.6not8.7 { catch {unset opt} catch {unset arg} set argList {-foo 123} list [catch { cmdline::typedGetopt argList {a.arg foo.bar b} opt arg } msg] $msg $argList $opt $arg } [list 1 {Illegal option type specification: must be one of alnum|alpha|ascii|control|boolean|digit|double|entier|false|graph|integer|list|lower|print|punct|space|true|upper|wideinteger|wordchar|xdigit} {-foo 123} {} {}] test typed-cmdline-6.14.1 {cmdline::typedGetopt, integer options} tcl8.5only} { catch {unset opt} catch {unset arg} set argList {-foo 123} list [catch { cmdline::typedGetopt argList {a.arg foo.bar b} opt arg } msg] $msg $argList $opt $arg } [list 1 {Illegal option type specification: must be one of alnum|alpha|ascii|control|boolean|digit|double|false|graph|integer|list|lower|print|punct|space|true|upper|wideinteger|wordchar|xdigit} {-foo 123} {} {}] test typed-cmdline-6.14.3 {cmdline::typedGetopt, integer options} tcl8.7not9 { catch {unset opt} catch {unset arg} set argList {-foo 123} list [catch {cmdline::typedGetopt argList {a.arg foo.bar b} opt arg} msg] $msg $argList $opt $arg } [list 1 {Illegal option type specification: must be one of alnum|alpha|ascii|control|boolean|dict|digit|double|entier|false|graph|integer|list|lower|print|punct|space|true|upper|unicode|wideinteger|wordchar|xdigit} {-foo 123} {} {}] test typed-cmdline-6.14.3 {cmdline::typedGetopt, integer options} tcl9plus { catch {unset opt} catch {unset arg} set argList {-foo 123} list [catch {cmdline::typedGetopt argList {a.arg foo.bar b} opt arg} msg] $msg $argList $opt $arg } [list 1 {Illegal option type specification: must be one of alnum|alpha|ascii|control|boolean|dict|digit|double|entier|false|graph|integer|list|lower|print|punct|space|true|upper|wideinteger|wordchar|xdigit} {-foo 123} {} {}] test typed-cmdline-6.15 {cmdline::typedGetopt, integer options} { catch {unset opt} catch {unset arg} set argList {-foo 123 -a 234} list [cmdline::typedGetopt argList {a.arg foo.integer b} opt arg] $argList $opt $arg } {1 {-a 234} foo 123} test typed-cmdline-6.16 {cmdline::typedGetopt, unusual integer options} { catch {unset opt} catch {unset arg} set argList {-* 123 -a 234} list [cmdline::typedGetopt argList {a.arg *.integer b} opt arg] $argList $opt $arg } {1 {-a 234} * 123} test typed-cmdline-6.17 {cmdline::typedGetopt, integer options} { catch {unset opt} catch {unset arg} set argList {-foo} list [cmdline::typedGetopt argList {a.arg foo.integer b} opt arg] $argList $opt $arg } {-2 {} foo {Option requires integer argument -- foo}} test typed-cmdline-6.18 {cmdline::typedGetopt, xdigit options} { catch {unset opt} catch {unset arg} set argList {-foo 50AC} list [cmdline::typedGetopt argList {foo.xdigit} opt arg] $argList $opt $arg } {1 {} foo 50AC} test typed-cmdline-6.19 {cmdline::typedGetopt, xdigit options} { catch {unset opt} catch {unset arg} set argList {-foo 50GC} list [cmdline::typedGetopt argList {foo.xdigit} opt arg] $argList $opt $arg } {-3 50GC foo {Option requires xdigit argument -- foo}} test typed-cmdline-6.20 {cmdline::typedGetopt, xdigit options} { catch {unset opt} catch {unset arg} set argList {-foo 50gc} list [cmdline::typedGetopt argList {foo.(50GC|50gc) bar} opt arg] $argList $opt $arg } {1 {} foo 50gc} test typed-cmdline-6.21 {cmdline::typedGetopt, xdigit options} { catch {unset opt} catch {unset arg} set argList {-foo 50gC} list [cmdline::typedGetopt argList {foo.(50GC|50gc) bar} opt arg] $argList $opt $arg } {-3 50gC foo {Option requires an argument, one of 50GC|50gc -- foo}} test typed-cmdline-6.22 {cmdline::typedGetopt, xdigit options} { catch {unset opt} catch {unset arg} set argList {-foo abc*def} list [cmdline::typedGetopt argList {foo.(abc*def|ghi?jkl) bar} opt arg] $argList $opt $arg } {1 {} foo abc*def} test typed-cmdline-6.23 {cmdline::typedGetopt, xdigit options} { catch {unset opt} catch {unset arg} set argList {-foo 50gc} list [cmdline::typedGetopt argList {foo.(x5MP|1jxR|50gc)? bar} opt arg] $argList $opt $arg } {1 {} foo 50gc} test typed-cmdline-6.24 {cmdline::typedGetopt, xdigit options} { catch {unset opt} catch {unset arg} set argList {-foo} list [cmdline::typedGetopt argList {foo.(x5MP|1jxR|50gc)? bar} opt arg] $argList $opt $arg } {1 {} foo {}} test typed-cmdline-6.25 {cmdline::typedGetopt, xdigit options} { catch {unset opt} catch {unset arg} set argList {-foo -bar} list [cmdline::typedGetopt argList {foo.(x5MP|1jxR|50gc)? bar} opt arg] $argList $opt $arg } {1 -bar foo {}} test typed-cmdline-6.26 {cmdline::typedGetopt, xdigit options} { catch {unset opt} catch {unset arg} set argList {-foo 50fc} list [cmdline::typedGetopt argList {foo.xdigit? bar} opt arg] $argList $opt $arg } {1 {} foo 50fc} test typed-cmdline-6.27 {cmdline::typedGetopt, xdigit options} { catch {unset opt} catch {unset arg} set argList {-foo} list [cmdline::typedGetopt argList {foo.xdigit? bar} opt arg] $argList $opt $arg } {1 {} foo {}} test typed-cmdline-6.28 {cmdline::typedGetopt, xdigit options} { catch {unset opt} catch {unset arg} set argList {-foo 1jxR -bar} list [cmdline::typedGetopt argList {foo.xdigit? bar} opt arg] $argList $opt $arg } {1 {1jxR -bar} foo {}} test typed-cmdline-6.29 {cmdline::typedGetopt, xdigit options} { catch {unset opt} catch {unset arg} set argList {-foo -bar} list [cmdline::typedGetopt argList {foo.xdigit? bar} opt arg] $argList $opt $arg } {1 -bar foo {}} test typed-cmdline-6.30 {cmdline::typedGetopt, xdigit options} { catch {unset opt} catch {unset arg} set argList {-foo} list [cmdline::typedGetopt argList {foo.xdigit+ bar} opt arg] $argList $opt $arg } {-2 {} foo {Option requires at least one xdigit argument -- foo}} test typed-cmdline-6.31 {cmdline::typedGetopt, xdigit options} { catch {unset opt} catch {unset arg} set argList {-foo AC} list [cmdline::typedGetopt argList {foo.xdigit+ bar} opt arg] $argList $opt $arg } {1 {} foo AC} test typed-cmdline-6.32 {cmdline::typedGetopt, xdigit options} { catch {unset opt} catch {unset arg} set argList {-foo AC 2F -bar} list [cmdline::typedGetopt argList {foo.xdigit+ bar} opt arg] $argList $opt $arg } {-3 -bar foo {Option requires xdigit argument -- foo}} test typed-cmdline-6.33 {cmdline::typedGetopt, xdigit options} { catch {unset opt} catch {unset arg} set argList {-foo AC 2F} list [cmdline::typedGetopt argList {foo.xdigit+ bar} opt arg] $argList $opt $arg } {1 {} foo {AC 2F}} test typed-cmdline-6.34 {cmdline::typedGetopt, xdigit options} { catch {unset opt} catch {unset arg} set argList {-foo AC 2F --} list [cmdline::typedGetopt argList {foo.xdigit+ bar} opt arg] $argList $opt $arg } {1 {} foo {AC 2F}} test typed-cmdline-6.35 {cmdline::typedGetopt, xdigit options} { catch {unset opt} catch {unset arg} set argList {-foo} list [cmdline::typedGetopt argList {foo.xdigit* bar} opt arg] $argList $opt $arg } {1 {} foo {}} test typed-cmdline-6.36 {cmdline::typedGetopt, xdigit options} { catch {unset opt} catch {unset arg} set argList {-foo AC} list [cmdline::typedGetopt argList {foo.xdigit* bar} opt arg] $argList $opt $arg } {1 {} foo AC} test typed-cmdline-6.37 {cmdline::typedGetopt, xdigit options} { catch {unset opt} catch {unset arg} set argList {-foo AC 2F -bar} list [cmdline::typedGetopt argList {foo.xdigit* bar} opt arg] $argList $opt $arg } {-3 -bar foo {Option requires xdigit argument -- foo}} test typed-cmdline-6.38 {cmdline::typedGetopt, xdigit options} { catch {unset opt} catch {unset arg} set argList {-foo AC 2F} list [cmdline::typedGetopt argList {foo.xdigit* bar} opt arg] $argList $opt $arg } {1 {} foo {AC 2F}} test typed-cmdline-6.39 {cmdline::typedGetopt, xdigit options} { catch {unset opt} catch {unset arg} set argList {-foo AC 2F --} list [cmdline::typedGetopt argList {foo.xdigit* bar} opt arg] $argList $opt $arg } {1 {} foo {AC 2F}} # cmdline::typedGetoptions test typed-cmdline-7.1 {cmdline::typedGetoptions} { set argList {foo} list [cmdline::typedGetoptions argList {}] $argList } {{} foo} test typed-cmdline-7.2 {cmdline::typedGetoptions, secret integer flag} { set argList {-foo 123} list [cmdline::typedGetoptions argList {{foo.integer.secret}}] $argList } {{foo 123} {}} test typed-cmdline-7.3 {cmdline::typedGetoptions, normal integer flag} { set argList {-foo 123} list [cmdline::typedGetoptions argList {{foo.integer}}] $argList } {{foo 123} {}} test typed-cmdline-7.4 {cmdline::typedGetoptions, missing integer flag, no default value} { set argList {} list [cmdline::typedGetoptions argList {{foo.integer}}] $argList } {{} {}} test typed-cmdline-7.5 {cmdline::typedGetoptions, missing integer flag, no default value} { set argList {} list [cmdline::typedGetoptions argList {{foo.integer {} {option foo with integer argument}}}] $argList } {{} {}} test typed-cmdline-7.6 {cmdline::typedGetoptions, integer flag, missing arg, no default value} { set argList {-foo} list [catch {cmdline::typedGetoptions argList {{foo.integer {} {blah blah}}}} msg] $msg $argList } [list 1 "[cmdline::getArgv0] options: -foo integer blah blah -help Print this message -? Print this message " {}] test typed-cmdline-7.7 {cmdline::typedGetoptions, integer flag, no default value} { set argList {-foo 123} list [cmdline::typedGetoptions argList {{foo.integer {} {option foo with integer argument}}}] $argList } {{foo 123} {}} test typed-cmdline-7.8 {cmdline::typedGetoptions, missing integer flag with arg, default value} { set argList {-* 123} list [dictsort [cmdline::typedGetoptions argList {{foo.integer 234} {*.double 5.234 {Unusual}}}]] $argList } {{* 123 foo 234} {}} test typed-cmdline-7.9 {cmdline::typedGetoptions, missing integer flag with arg, default value} { set argList {-f} list [dictsort [cmdline::typedGetoptions argList {{foo.integer 234} {*.double 5.234 {Unusual}}}]] $argList } {{* 5.234 foo 234} {}} test typed-cmdline-7.10 {cmdline::typedGetoptions, missing integer flag with arg, default value} { set argList {-f} list [catch {cmdline::typedGetoptions argList {foo.integer *.double fooey}} msg] $msg $argList } [list 1 "[cmdline::getArgv0] options: -foo integer -* double -fooey -help Print this message -? Print this message " -f] test typed-cmdline-7.11 {cmdline::typedGetoptions, missing integer flag with arg, default value} { set argList {} list [cmdline::typedGetoptions argList {{foo.integer 234}}] $argList } {{foo 234} {}} test typed-cmdline-7.12 {cmdline::typedGetoptions, integer flag with arg, default value} { set argList {-foo 123} list [cmdline::typedGetoptions argList {{foo.integer 234}}] $argList } {{foo 123} {}} test typed-cmdline-7.13 {cmdline::typedGetoptions, multiple flags with arg, default value} { set argList {} list [dictsort [cmdline::typedGetoptions argList {{foo.arg blat} {a.arg b}}]] $argList } {{a b foo blat} {}} test typed-cmdline-7.14 {cmdline::typedGetoptions, errors} { set argList {-a -foo} list [dictsort [cmdline::typedGetoptions argList {{foo.arg blat} a}]] $argList } {{a {} foo blat} {}} test typed-cmdline-7.15 {cmdline::typedGetoptions, errors} { set argList {-a -fo} list [dictsort [cmdline::typedGetoptions argList {{foo.arg blat} a}]] $argList } {{a {} foo blat} {}} test typed-cmdline-7.16 {cmdline::typedGetopt, xdigit options} { set argList {-foo 50gc} list [cmdline::typedGetoptions argList {foo.(50GC|50gc) bar}] $argList } {{foo 50gc} {}} test typed-cmdline-7.17 {cmdline::typedGetopt, xdigit options} { set argList {-foo -bar} list [cmdline::typedGetoptions argList {foo.(50GC|50gc)? bar}] $argList } {{foo {} bar {}} {}} test typed-cmdline-7.18 {cmdline::typedGetopt, xdigit options} { set argList {-bar -foo 123 234} list [cmdline::typedGetoptions argList {foo.integer+ bar}] $argList } {{foo {123 234} bar {}} {}} test typed-cmdline-7.19 {cmdline::typedGetopt, xdigit options} { set argList {-bar -foo 123 234} list [cmdline::typedGetoptions argList {foo.integer* bar}] $argList } {{foo {123 234} bar {}} {}} test typed-cmdline-7.20 {cmdline::typedGetopt, xdigit options} { set argList {-foo 50gC} list [catch {cmdline::typedGetoptions argList {foo.(50GC|50gc) bar}} msg] $msg $argList } [list 1 "[cmdline::getArgv0] options: -foo 50GC|50gc -bar -help Print this message -? Print this message " 50gC] test typed-cmdline-7.21 {cmdline::typedGetoptions, errors} { set argList {-b -foo} list [catch {cmdline::typedGetoptions argList {foo.arg a}} msg] $msg $argList } [list 1 "[cmdline::getArgv0] options: -foo arg -a -help Print this message -? Print this message " {-b -foo}] test typed-cmdline-7.22 {cmdline::typedGetoptions, errors} { set argList {-b -foo} list [catch {cmdline::typedGetoptions argList {{foo.arg {} {blah blah}} a}} msg] $msg $argList } [list 1 "[cmdline::getArgv0] options: -foo arg blah blah -a -help Print this message -? Print this message " {-b -foo}] test typed-cmdline-7.23 {cmdline::typedGetoptions, errors} { set argList {-a -?} list [catch {cmdline::typedGetoptions argList {{foo.arg blat} a}} msg] $msg \ $argList } [list 1 "[cmdline::getArgv0] options: -foo arg -a -help Print this message -? Print this message " {}] test typed-cmdline-7.24 {cmdline::typedGetoptions, errors} { set argList {-help} list [catch {cmdline::typedGetoptions argList {{foo.arg blat} a}} msg] $msg \ $argList } [list 1 "[cmdline::getArgv0] options: -foo arg -a -help Print this message -? Print this message " {}] test typed-cmdline-7.25 {cmdline::typedGetoptions, usage string in errors} { set argList {-help} list [catch {cmdline::typedGetoptions argList {{foo.arg blat} a} {testing:}} msg] $msg \ $argList } [list 1 "[cmdline::getArgv0] testing: -foo arg -a -help Print this message -? Print this message " {}] test typed-cmdline-7.26 {cmdline::typedGetoptions, unusual option} { set argList {-x?y -a -foo} list [dictsort [cmdline::typedGetoptions argList {{foo.arg blat} x?y x*y a}]] $argList } {{a {} foo blat x?y {}} {}} test typed-cmdline-7.27 {cmdline::typedGetoptions, unusual option, abbreviation error} { set argList {-x -a -foo} list [catch {cmdline::typedGetoptions argList {{foo.arg blat} x?y x*y a}} msg] $msg $argList } [list 1 "[cmdline::getArgv0] options: -foo arg -x?y -x*y -a -help Print this message -? Print this message " {-x -a -foo}] test typed-cmdline-7.28 {cmdline::typedGetoptions, unusual option, abbreviation} { set argList {-x -a -foo} list [dictsort [cmdline::typedGetoptions argList {{foo.arg blat} x?y a}]] $argList } {{a {} foo blat x?y {}} {}} test typed-cmdline-7.29 {cmdline::typedGetoptions, multiple integer flag} { set argList {-foo 123 -foo 234} list [cmdline::typedGetoptions argList {{foo.integer.multi}}] $argList } {{foo {123 234}} {}} test typed-cmdline-7.30 {cmdline::typedGetoptions, multiple quoted arg flag} { set argList {-foo "123 234" -foo "234 345"} list [cmdline::typedGetoptions argList {{foo.arg.multi}}] $argList } {{foo {{123 234} {234 345}}} {}} test typed-cmdline-7.31 {cmdline::typedGetoptions, multiple boolean flag} { set argList {-foo} list [cmdline::typedGetoptions argList {{foo.multi}}] $argList } {{foo {}} {}} test typed-cmdline-7.32 {cmdline::typedGetoptions, multiple boolean flag} { set argList {-foo -foo} list [cmdline::typedGetoptions argList {{foo.multi}}] $argList } {{} {}} test typed-cmdline-7.33 {cmdline::typedGetoptions, multiple boolean flag} { set argList {-foo -foo -foo} list [cmdline::typedGetoptions argList {{foo.multi}}] $argList } {{foo {}} {}} testsuiteCleanup return tcltk2/inst/tklibs/cmdline1.5.3/cmdline.test0000644000176200001440000004407715017041713020251 0ustar liggesusers# -*- tcl -*- # This file contains the tests for the cmdline.tcl file. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1999 by Ajuba Solutions. # All rights reserved. # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.5 testsNeedTcltest 1.0 testing { useLocal cmdline.tcl cmdline } # ------------------------------------------------------------------------- set cmdLineFile [localPath cmdline.tcl] set argv0 "argv0" # --------------------------------------------------- # cmdline::getopt test cmdline-1.1 {cmdline::getopt} { catch {unset opt} catch {unset arg} set argList {} list [cmdline::getopt argList {a} opt arg] $argList $opt $arg } {0 {} {} {}} test cmdline-1.2 {cmdline::getopt, multiple options} { catch {unset opt} catch {unset arg} set argList {} list [cmdline::getopt argList {a b.arg c} opt arg] $argList $opt $arg } {0 {} {} {}} test cmdline-1.3 {cmdline::getopt, -- option} { catch {unset opt} catch {unset arg} set argList {-- -a} list [cmdline::getopt argList {a} opt arg] $argList $opt $arg } {0 -a {} {}} test cmdline-1.4 {cmdline::getopt, non dash option} { catch {unset opt} catch {unset arg} set argList {b -a} list [cmdline::getopt argList {a} opt arg] $argList $opt $arg } {0 {b -a} {} {}} test cmdline-1.5 {cmdline::getopt, simple option} { catch {unset opt} catch {unset arg} set argList {-a b} list [cmdline::getopt argList {a} opt arg] $argList $opt $arg } {1 b a 1} test cmdline-1.6 {cmdline::getopt, multiple letter option} { catch {unset opt} catch {unset arg} set argList {-foo b} list [cmdline::getopt argList {foo} opt arg] $argList $opt $arg } {1 b foo 1} test cmdline-1.7 {cmdline::getopt, multiple letter option, no abbreviations} { catch {unset opt} catch {unset arg} set argList {-f b} list [cmdline::getopt argList {foo} opt arg] $argList $opt $arg } {-1 {-f b} f {Illegal option "-f"}} test cmdline-1.8 {cmdline::getopt, option with argument} { catch {unset opt} catch {unset arg} set argList {-foo bar baz} list [cmdline::getopt argList {foo.arg} opt arg] $argList $opt $arg } {1 baz foo bar} test cmdline-1.9 {cmdline::getopt, option with argument, missing arg} { catch {unset opt} catch {unset arg} set argList {-foo} list [cmdline::getopt argList {foo.arg} opt arg] $argList $opt $arg } {-1 {} foo {Option "foo" requires an argument}} test cmdline-1.10 {cmdline::getopt, unknown option} { catch {unset opt} catch {unset arg} set argList {-bar} list [cmdline::getopt argList {foo.arg} opt arg] $argList $opt $arg } {-1 -bar bar {Illegal option "-bar"}} test cmdline-1.11 {cmdline::getopt, multiple options} { catch {unset opt} catch {unset arg} set argList {-foo} list [cmdline::getopt argList {a.arg b foo c.arg} opt arg] $argList $opt $arg } {1 {} foo 1} test cmdline-1.12 {cmdline::getopt, option with argument, -o=v syntax} { catch {unset opt} catch {unset arg} set argList {-foo=bar baz} list [cmdline::getopt argList {foo.arg} opt arg] $argList $opt $arg } {1 baz foo bar} test cmdline-1.13 {cmdline::getopt, option with argument, --o=v syntax} { catch {unset opt} catch {unset arg} set argList {--foo=bar baz} list [cmdline::getopt argList {foo.arg} opt arg] $argList $opt $arg } {1 baz foo bar} # cmdline::getoptions test cmdline-2.1 {cmdline::getoptions} { set argList {foo} list [cmdline::getoptions argList {}] $argList } {{} foo} test cmdline-2.2 {cmdline::getoptions, secret flag} { set argList {-foo} list [cmdline::getoptions argList {{foo.secret}}] $argList } {{foo 1} {}} test cmdline-2.3 {cmdline::getoptions, normal flag} { set argList {-foo} list [cmdline::getoptions argList {{foo}}] $argList } {{foo 1} {}} test cmdline-2.4 {cmdline::getoptions, flag with arg} { set argList {-foo bar} list [cmdline::getoptions argList {{foo.arg}}] $argList } {{foo bar} {}} test cmdline-2.5 {cmdline::getoptions, missing flag with arg, default value} { set argList {} list [cmdline::getoptions argList {{foo.arg blat}}] $argList } {{foo blat} {}} test cmdline-2.6 {cmdline::getoptions, flag with arg, default value} { set argList {-foo bar} list [cmdline::getoptions argList {{foo.arg blat}}] $argList } {{foo bar} {}} test cmdline-2.7 {cmdline::getoptions, multiple flags with arg, default value} { set argList {} list [dictsort [cmdline::getoptions argList {{foo.arg blat} {a.arg b}}]] $argList } {{a b foo blat} {}} test cmdline-2.8 {cmdline::getoptions, errors} { set argList {-a -foo} list [catch {cmdline::getoptions argList {{foo.arg blat} a}} msg] $msg $argList } [list 1 "[cmdline::getArgv0] options: -foo value -a -- Forcibly stop option processing -help Print this message -? Print this message " {}] test cmdline-2.9 {cmdline::getoptions, errors} { set argList {-a -?} list [catch {cmdline::getoptions argList {{foo.arg blat} a}} msg] $msg \ $argList } [list 1 "[cmdline::getArgv0] options: -foo value -a -- Forcibly stop option processing -help Print this message -? Print this message " {}] test cmdline-2.10 {cmdline::getoptions, errors} { set argList {-help} list [catch {cmdline::getoptions argList {{foo.arg blat} a}} msg] $msg \ $argList } [list 1 "[cmdline::getArgv0] options: -foo value -a -- Forcibly stop option processing -help Print this message -? Print this message " {}] test cmdline-2.11 {cmdline::getoptions, usage string in errors} { set argList {-help} list [catch {cmdline::getoptions argList {{foo.arg blat} a} {testing}} msg] $msg \ $argList } [list 1 "[cmdline::getArgv0] testing -foo value -a -- Forcibly stop option processing -help Print this message -? Print this message " {}] test cmdline-2.12 {cmdline::getoptions, bug 3189786} { set argList {-help} list [catch {cmdline::getoptions argList {myarg a} {testing}} msg] $msg \ $argList } [list 1 "[cmdline::getArgv0] testing -myarg -a -- Forcibly stop option processing -help Print this message -? Print this message " {}] # cmdline::usage test cmdline-3.1 {cmdline::usage,hidden options} { set argList {-help} list [catch {cmdline::getoptions argList {{foo.secret blat} a}} msg] $msg \ $argList } [list 1 "[cmdline::getArgv0] options: -a -- Forcibly stop option processing -help Print this message -? Print this message " {}] test cmdline-3.2 {cmdline::usage, with & without arg} { set argList {-help} list [catch {cmdline::getoptions argList \ {{foo.arg blat testing} {a {} {line 2}}}} msg] $msg $argList } [list 1 "[cmdline::getArgv0] options: -foo value testing -a -- Forcibly stop option processing -help Print this message -? Print this message " {}] test cmdline-3.3 {cmdline::usage, bug 3189786} { set argList {-help} list [catch {cmdline::getoptions argList {{mysecret blat} a}} msg] $msg \ $argList } [list 1 "[cmdline::getArgv0] options: -mysecret blat -a -- Forcibly stop option processing -help Print this message -? Print this message " {}] test cmdline-3.4 {cmdline::usage, long options} { set argList {-help} list [catch {cmdline::getoptions argList {{mysecret blat} a {very-long-option.arg foobar {A very very long option}}}} msg] $msg \ $argList } [list 1 "[cmdline::getArgv0] options: -mysecret blat -a -very-long-option value A very very long option -- Forcibly stop option processing -help Print this message -? Print this message " {}] # cmdline::getfiles # Run the script body in a slave process so we can collect stdout. proc runGetFilesTest {body} { set script "source [list $::cmdLineFile]\n" append script "cd [list $::tcltest::temporaryDirectory]\n" append script $body set scriptfile [makeFile $script script] set f [open "|[list $::tcltest::tcltest $scriptfile]" r] set result [read $f] close $f removeFile script return $result } # Create a directory with some files in it makeDirectory cmdlineJunk set foo1 [makeFile {} cmdlineJunk/foo1] set foo2 [makeFile {} cmdlineJunk/foo2] set bar3 [makeFile {} cmdlineJunk/bar3] test cmdline-4.1 {cmdline::getfiles} {pcOnly} { runGetFilesTest { cmdline::getfiles {} 0 } } {} test cmdline-4.2 {cmdline::getfiles, one pattern} {pcOnly} { runGetFilesTest { cd cmdlineJunk set result [cmdline::getfiles {foo*} 0] puts -nonewline [lsort $result] exit } } [list $foo1 $foo2] test cmdline-4.3 {cmdline::getfiles, multiple patterns} {pcOnly} { runGetFilesTest { cd cmdlineJunk set result [cmdline::getfiles {foo* bar*} 0] puts -nonewline [lsort $result] exit } } [list $bar3 $foo1 $foo2] test cmdline-4.4 {cmdline::getfiles, no match} {pcOnly} { runGetFilesTest { cd cmdlineJunk set result [cmdline::getfiles {blat* foo*} 0] puts -nonewline [lsort $result] exit } } "warning: no files match \"blat*\"\n[list $foo1 $foo2]" test cmdline-4.5 {cmdline::getfiles, quiet} {pcOnly} { runGetFilesTest { cd cmdlineJunk set result [cmdline::getfiles {blat* foo*} 1] puts -nonewline [lsort $result] exit } } [list $foo1 $foo2] test cmdline-4.6 {cmdline::getfiles, relative paths} { runGetFilesTest { cd cmdlineJunk set result [cmdline::getfiles {foo1 foo2} 0] puts -nonewline [lsort $result] exit } } [list $foo1 $foo2] test cmdline-4.7 {cmdline::getfiles, absolute paths} { runGetFilesTest { cd cmdlineJunk set result [cmdline::getfiles [list [file join [pwd] foo1]] 0] puts -nonewline [lsort $result] exit } } [list $foo1] test cmdline-4.8 {cmdline::getfiles, no match} { runGetFilesTest { cd cmdlineJunk set result [cmdline::getfiles {blat foo1} 0] puts -nonewline [lsort $result] exit } } "warning: no files match \"blat\"\n[list $foo1]" test cmdline-4.9 {cmdline::getfiles, silent no match} { runGetFilesTest { cd cmdlineJunk set result [cmdline::getfiles {blat foo1} 1] puts -nonewline [lsort $result] exit } } [list $foo1] test cmdline-4.10 {cmdline::getfiles, backslashes on windows} {pc} { runGetFilesTest { set result [cmdline::getfiles {cmdlineJunk\\foo*} 1] puts -nonewline [lsort $result] exit } } [list $foo1 $foo2] # Remove the temporary directory and files from the previous tests removeFile cmdlineJunk/foo1 removeFile cmdlineJunk/foo2 removeFile cmdlineJunk/bar3 removeDirectory cmdlineJunk # cmdline::getArgv0 test cmdline-5.1 {cmdline::getArgv0} { set oldargv0 $argv0 set argv0 "foo" set result [cmdline::getArgv0] set argv0 $oldargv0 set result } foo test cmdline-5.2 {cmdline::getArgv0} { set oldargv0 $argv0 set argv0 "foo.exe" set result [cmdline::getArgv0] set argv0 $oldargv0 set result } foo test cmdline-5.3 {cmdline::getArgv0} { set oldargv0 $argv0 set argv0 "foo.bin" set result [cmdline::getArgv0] set argv0 $oldargv0 set result } foo test cmdline-5.4 {cmdline::getArgv0} { set oldargv0 $argv0 set argv0 "foo.bar.bin" set result [cmdline::getArgv0] set argv0 $oldargv0 set result } foo.bar test cmdline-5.5 {cmdline::getArgv0} { set oldargv0 $argv0 set argv0 "/a/b/c/foo" set result [cmdline::getArgv0] set argv0 $oldargv0 set result } foo # cmdline::getKnownOpt test cmdline-6.1 {cmdline::getKnownOpt} { catch {unset opt} catch {unset arg} set argList {} list [cmdline::getKnownOpt argList {a} opt arg] $argList $opt $arg } {0 {} {} {}} test cmdline-6.2 {cmdline::getKnownOpt, multiple options} { catch {unset opt} catch {unset arg} set argList {} list [cmdline::getKnownOpt argList {a b.arg c} opt arg] $argList $opt $arg } {0 {} {} {}} test cmdline-6.3 {cmdline::getKnownOpt, -- option} { catch {unset opt} catch {unset arg} set argList {-- -a} list [cmdline::getKnownOpt argList {a} opt arg] $argList $opt $arg } {0 -a {} {}} test cmdline-6.4 {cmdline::getKnownOpt, non dash option} { catch {unset opt} catch {unset arg} set argList {b -a} list [cmdline::getKnownOpt argList {a} opt arg] $argList $opt $arg } {0 {b -a} {} {}} test cmdline-6.5 {cmdline::getKnownOpt, simple option} { catch {unset opt} catch {unset arg} set argList {-a b} list [cmdline::getKnownOpt argList {a} opt arg] $argList $opt $arg } {1 b a 1} test cmdline-6.6 {cmdline::getKnownOpt, multiple letter option} { catch {unset opt} catch {unset arg} set argList {-foo b} list [cmdline::getKnownOpt argList {foo} opt arg] $argList $opt $arg } {1 b foo 1} test cmdline-6.7 {cmdline::getKnownOpt, multiple letter option, no abbreviations} { catch {unset opt} catch {unset arg} set argList {-f b} list [cmdline::getKnownOpt argList {foo} opt arg] $argList $opt $arg } {-1 {-f b} f {Illegal option "-f"}} test cmdline-6.8 {cmdline::getKnownOpt, option with argument} { catch {unset opt} catch {unset arg} set argList {-foo bar baz} list [cmdline::getKnownOpt argList {foo.arg} opt arg] $argList $opt $arg } {1 baz foo bar} test cmdline-6.9 {cmdline::getKnownOpt, option with argument, missing arg} { catch {unset opt} catch {unset arg} set argList {-foo} list [cmdline::getKnownOpt argList {foo.arg} opt arg] $argList $opt $arg } {-2 {} foo {Option "foo" requires an argument}} test cmdline-6.10 {cmdline::getKnownOpt, unknown option} { catch {unset opt} catch {unset arg} set argList {-bar} list [cmdline::getKnownOpt argList {foo.arg} opt arg] $argList $opt $arg } {-1 -bar bar {Illegal option "-bar"}} test cmdline-6.11 {cmdline::getKnownOpt, multiple options} { catch {unset opt} catch {unset arg} set argList {-foo} list [cmdline::getKnownOpt argList {a.arg b foo c.arg} opt arg] $argList $opt $arg } {1 {} foo 1} # cmdline::getKnownOptions test cmdline-7.1 {cmdline::getKnownOptions} { set argList {foo} list [cmdline::getKnownOptions argList {}] $argList } {{} foo} test cmdline-7.2 {cmdline::getKnownOptions, secret flag} { set argList {-foo} list [cmdline::getKnownOptions argList {{foo.secret}}] $argList } {{foo 1} {}} test cmdline-7.3 {cmdline::getKnownOptions, normal flag} { set argList {-foo} list [cmdline::getKnownOptions argList {{foo}}] $argList } {{foo 1} {}} test cmdline-7.4 {cmdline::getKnownOptions, flag with arg} { set argList {-foo bar} list [cmdline::getKnownOptions argList {{foo.arg}}] $argList } {{foo bar} {}} test cmdline-7.5 {cmdline::getKnownOptions, missing flag with arg, default value} { set argList {} list [cmdline::getKnownOptions argList {{foo.arg blat}}] $argList } {{foo blat} {}} test cmdline-7.6 {cmdline::getKnownOptions, flag with arg, default value} { set argList {-foo bar} list [cmdline::getKnownOptions argList {{foo.arg blat}}] $argList } {{foo bar} {}} test cmdline-7.7 {cmdline::getKnownOptions, multiple flags with arg, default value} { set argList {} list [dictsort [cmdline::getKnownOptions argList {{foo.arg blat} {a.arg b}}]] $argList } {{a b foo blat} {}} test cmdline-7.8 {cmdline::getKnownOptions, ignore unknown option} { set argList {-unknown -foo buzz} list [cmdline::getKnownOptions argList {{foo.arg blat}}] $argList } {{foo buzz} -unknown} test cmdline-7.9 {cmdline::getKnownOptions, ignore unknown option} { set argList {-foo buzz -unknown} list [cmdline::getKnownOptions argList {{foo.arg blat}}] $argList } {{foo buzz} -unknown} test cmdline-7.10 {cmdline::getKnownOptions, ignore unknown option with args} { set argList {-unknown u1 u2 u3 -foo buzz} list [cmdline::getKnownOptions argList {{foo.arg blat}}] $argList } {{foo buzz} {-unknown u1 u2 u3}} test cmdline-7.11 {cmdline::getKnownOptions, ignore unknown option with args} { set argList {-foo buzz -unknown u1 u2 u3} list [cmdline::getKnownOptions argList {{foo.arg blat}}] $argList } {{foo buzz} {-unknown u1 u2 u3}} test cmdline-7.12 {cmdline::getKnownOptions, errors} { set argList {-a -foo} list [catch {cmdline::getKnownOptions argList {{foo.arg blat} a}} msg] $msg $argList } [list 1 "[cmdline::getArgv0] options: -foo value -a -- Forcibly stop option processing -help Print this message -? Print this message " {}] test cmdline-7.13 {cmdline::getKnownOptions, errors} { set argList {-a -?} list [catch {cmdline::getKnownOptions argList {{foo.arg blat} a}} msg] $msg \ $argList } [list 1 "[cmdline::getArgv0] options: -foo value -a -- Forcibly stop option processing -help Print this message -? Print this message " {}] test cmdline-7.14 {cmdline::getKnownOptions, errors} { set argList {-help} list [catch {cmdline::getKnownOptions argList {{foo.arg blat} a}} msg] $msg \ $argList } [list 1 "[cmdline::getArgv0] options: -foo value -a -- Forcibly stop option processing -help Print this message -? Print this message " {}] test cmdline-7.15 {cmdline::getKnownOptions, usage string in errors} { set argList {-help} list [catch {cmdline::getKnownOptions argList {{foo.arg blat} a} {testing}} msg] $msg \ $argList } [list 1 "[cmdline::getArgv0] testing -foo value -a -- Forcibly stop option processing -help Print this message -? Print this message " {}] testsuiteCleanup return tcltk2/inst/tklibs/tooltip2.0.1/0000755000176200001440000000000015017041713015772 5ustar liggesuserstcltk2/inst/tklibs/tooltip2.0.1/tipstack.man0000644000176200001440000000563215017041713020317 0ustar liggesusers[comment {-*- tcl -*- doctools manpage}] [vset VERSION 1.0.1] [manpage_begin tipstack n [vset VERSION]] [keywords balloon] [keywords help] [keywords hover] [keywords tipstack] [copyright {2003 ActiveState Corp}] [moddesc {Tooltip management}] [titledesc {Stacked tooltips}] [require Tcl 8.5] [require msgcat 1.3] [require tooltip [opt 1.7]] [require tipstack [opt [vset VERSION]]] [description] [para] This package extends the functionality of package [package tooltip]. It provides a dynamic stack of tip texts per widget. This enables dynamic transient changes to the tips, for example to temporarily replace a standard explanation of a field with an error message. [section {COMMANDS}] [list_begin definitions] [call [cmd ::tipstack::push] [arg widget] [opt "[option -index] [arg index]"] [arg text]] Push a new [arg text] to the tooltip for the [arg widget]. In case of a list widget use [example {-index ...}] to address the particular entry to change the tooltip for. [para] The result of the command is the empty string [call [cmd ::tipstack::pop] [arg widget] [opt "[option -index] [arg index]"]] Pop the current tooltip for the [arg widget] from the stack and restore the previous text. This is a no-operation if this would leave an empty stack behind. In other words, the baseline tooltip text cannot be popped of. In case of a list widget use [example {-index ...}] to address the particular entry to change the tooltip for. [para] The result of the command is the empty string [call [cmd ::tipstack::clear] [arg widget] [opt "[option -index] [arg index]"]] Clear the stack for the [arg widget] and restore back to the baseline. In case of a list widget use [example {-index ...}] to address the particular entry to change the tooltip for. [para] The result of the command is the empty string [call [cmd ::tipstack::def] [arg widget] [arg text] ...] Perform multiple pushes for a number of independent [arg widget]s in a single call. This command cannot be used for list widgets, as it does not allow the passing of the necessary index information. Use with menus is not possible either. [para] The result of the command is the empty string [call [cmd ::tipstack::defsub] [arg base] [arg widget] [arg text] ...] This command is a variant of [cmd ::tipstack::def] where all the widgets to push to are subwidgets of the [arg base]. This is good for mega-widgets. [para] Note that either each [arg widget] has to be specified with a proper leading dot ([const .]), or the [arg base] has to be specigfied with a trailing dot. [para] The result of the command is the empty string [call [cmd ::tipstack::clearsub] [arg base]] This command is a variant of [cmd ::tipstack::clear] which clears all child widgets of the [arg base] text was pushed to. Use with menus is not possible. [para] The result of the command is the empty string [list_end] [vset CATEGORY tooltip] [include ../../support/devel/doc/feedback.inc] [manpage_end] tcltk2/inst/tklibs/tooltip2.0.1/tooltip.man0000644000176200001440000001547615017041713020176 0ustar liggesusers[comment {-*- tcl -*- doctools manpage}] [vset VERSION 2.0.1] [manpage_begin tooltip n [vset VERSION]] [keywords balloon] [keywords help] [keywords hover] [keywords tooltip] [copyright {1996-2008, Jeffrey Hobbs}] [copyright {2024 Emmanuel Frecon}] [moddesc {Tooltip management}] [titledesc {Tooltip management}] [require Tcl 8.5] [require tooltip [opt [vset VERSION]]] [description] [para] This package provides tooltips, i.e., small text messages that can be displayed when the mouse hovers over a widget, menu item, canvas item, listbox item, ttk::treeview item or column heading, ttk::notebook tab, or text widget tag. [section {COMMANDS}] [list_begin definitions] [call [cmd ::tooltip::tooltip] [arg command] [opt [arg options]]] Manage the tooltip package using the following subcommands. [list_begin options] [opt_def clear [opt [arg pattern]]] Prevents the specified widgets from showing tooltips. [arg pattern] is a glob pattern and defaults to matching all widgets. [opt_def configure [opt "[arg option] [opt "[arg "value option value"] ..."]"]] Queries or modifies the configuration options of the tooltip. The supported options are [option -backgroud], [option -foreground] and [option -font]. If no [arg option] is specified, returns a dictionary of the option values. If one [arg option] is specified with no value, returns the value of that option. Otherwise, sets the given [arg option]s to the corresponding [arg value]s. [opt_def delay [opt [arg millisecs]]] Query or set the hover delay. This is the interval that the pointer must remain over the widget before the tooltip is displayed. The delay is specified in milliseconds and must be greater than or equal to 50 ms. With no argument the current delay is returned. [opt_def fade [opt [arg boolean]]] Enable or disable fading of the tooltip. The fading is enabled by default on Win32 and Aqua. The tooltip will fade away on Leave events instead disappearing. [opt_def disable] [opt_def off] Disable all tooltips [opt_def enable] [opt_def on] Enables tooltips for defined widgets. [list_end] [para] [call [cmd ::tooltip::tooltip] [arg pathName] [opt [arg "option value"]...] \ [opt [const --]] [arg message]] This command arranges for widget [arg pathName] to display a tooltip with a [arg message]. [para] If the specified widget is a [cmd menu], [cmd canvas], [cmd listbox], [cmd ttk::treeview], [cmd ttk::notebook] or [cmd text] widget then additional options are used to tie the tooltip to specific menu, canvas or listbox items, ttk::treeview items or column headings, ttk::notebook tabs, or text widget tags. [list_begin options] [opt_def -heading [arg columnId]] This option is used to set a tooltip for a ttk::treeview column heading. The column does not need to already exist. You should not use the same identifiers for columns and items in a widget for which you are using tooltips as their tooltips will be mixed. The widget must be a ttk::treeview widget. [opt_def -image [arg image]] The specified (photo) image will be displayed to the left of the primary tooltip [arg message]. [opt_def -index [arg index]] This option is used to set a tooltip on a menu item. The index may be either the entry index or the entry label. The widget must be a menu widget but the entries do not have to exist when the tooltip is set. [opt_def -info [arg info]] The specified [arg info] text will be displayed as additional information below the primary tooltip [arg message]. [opt_def -items [arg items]] This option is used to set a tooltip for canvas, listbox or ttk::treview items. For the canvas widget, the item must already be present in the canvas and will be found with a [cmd "find withtag"] lookup. For listbox and ttk::treview widgets the item(s) may be created later but the programmer is responsible for managing the link between the listbox or ttk::treview item index and the corresponding tooltip. If the listbox or ttk::treview items are re-ordered, the tooltips will need amending. [para] If the widget is not a canvas, listbox or ttk::treview then an error is raised. [opt_def -tab [arg tabId]] The [option -tab] option can be used to set a tooltip for a ttk::notebook tab. The tab should already be present when this command is called, or an error will be returned. The widget must be a ttk::notebook widget. [opt_def -tag [arg name]] The [option -tag] option can be used to set a tooltip for a text widget tag. The tag should already be present when this command is called, or an error will be returned. The widget must be a text widget. [opt_def --] The [option --] option marks the end of options. The argument following this one will be treated as [arg message] even if it starts with a [const -]. [list_end] [list_end] [section EXAMPLE] [example { # Demonstrate widget tooltip package require tooltip pack [label .l -text "label"] tooltip::tooltip .l "This is a label widget" }] [example { # Demonstrate menu tooltip package require tooltip . configure -menu [menu .menu] .menu add cascade -label Test -menu [menu .menu.test -tearoff 0] .menu.test add command -label Tooltip tooltip::tooltip .menu.test -index 0 "This is a menu tooltip" }] [example { # Demonstrate canvas item tooltip package require tooltip pack [canvas .c] set item [.c create rectangle 10 10 80 80 -fill red] tooltip::tooltip .c -item $item "Canvas item tooltip" }] [example { # Demonstrate listbox item tooltip package require tooltip pack [listbox .lb] .lb insert 0 "item one" tooltip::tooltip .lb -item 0 "Listbox item tooltip" }] [example { # Demonstrate ttk::notebook tab tooltip package require tooltip pack [ttk::notebook .nb] .nb add [frame .nb.f1 -height 50] -text "First tab" .nb add [frame .nb.f2 -height 50] -text "Second tab" tooltip::tooltip .nb -tab 0 "Tooltip for the 1st notebook tab" tooltip::tooltip .nb -tab 1 "Tooltip for the 2nd notebook tab" }] [example { # Demonstrate text tag tooltip package require tooltip pack [text .txt] .txt tag configure TIP-1 -underline 1 tooltip::tooltip .txt -tag TIP-1 "tooltip one text" .txt insert end "An example of a " {} "tooltip" TIP-1 " tag.\n" {} }] [section {Migration from Version 1}] Version 1.3 to 1.7 called [cmd msgcat::mc] before a tooltip was shown, using the tooltip namespace. [cmd msgcat::mc] requires the caller environment. Due to that, version 1.8 recorded the caller namespace and used this in the call. In version 2.0, any [cmd msgcat::mc] support was removed. The options [option -namespace], [option -msgargs] and [option -infoargs] were removed. Starting with TCL 8.7, [cmd msgcat::mc] supports oo classes and oo methods. But the oo caller environment is not present when the [cmd msgcat::mc] was invoked on tooltip display, resulting in runtime errors. It was concluded as bad design to call [cmd msgcat::mc] late. The caller should reinstall the tooltips on eventual message change. [vset CATEGORY tooltip] [include ../../support/devel/doc/feedback.inc] [manpage_end] tcltk2/inst/tklibs/tooltip2.0.1/pkgIndex.tcl0000644000176200001440000000024615017041713020251 0ustar liggesusers# -*- tcl -*- package ifneeded tooltip 2.0.1 [list source [file join $dir tooltip.tcl]] package ifneeded tipstack 1.0.1 [list source [file join $dir tipstack.tcl]] tcltk2/inst/tklibs/tooltip2.0.1/ChangeLog0000644000176200001440000001561015017041713017547 0ustar liggesusers2024-07-18 Harald Oehlmann * pkgIndex.tcl: Bumped the tooltip version number to 2.0.0. * tooltip.man: Removed msgcat information * tooltip.tcl: Removed all msgcat code and options -namespace, -msgargs and -infoargs. The implemented late binding is not possible, if the creation command is called from an oo class or method. See Ticket [https://core.tcl-lang.org/tklib/info/6e85abae9e49281b] 2024-06-26 Csaba Nemethi * pkgIndex.tcl: Bumped the tooltip version number to 1.8.2. * tooltip.man: * tooltip.tcl: Fixed a few bugs related to "option add" and the proc tooltip::configure; bumped the version number to 1.8.2. 2024-05-23 Andreas Kupries * Bumped to version 1.8. Support images and additional info text. Ticket [https://core.tcl-lang.org/tklib/tktview/803a13c9f0]. Patch by Rene Zaumseil. * Evaluate msgcat in the callers namespace. New options -namespace, -msgargs, infoargs to specify the namespace and the arguments to the msgcat::mc call. Patch by Harald Oehlmann Ticket [https://core.tcl-lang.org/tklib/info/3300362fffffffff]. 2024-05-22 Andreas Kupries * Bumped to version 1.7.1. Bail if widget goes away during early idletasks in `show`. Ticket [https://core.tcl-lang.org/tklib/tktview/ff46309014]. Patch by Emmanuel Frecon. 2024-05-05 Csaba Nemethi * pkgIndex.tcl: Bumped the tooltip version number to 1.7. * tooltip.tcl: Added support for ttk::treeview column headings (based * tooltip.man: on a patch submitted by Mathias Kende); bumped the version number to 1.7 (fix for ticket [2895994fff]). 2022-08-22 Csaba Nemethi * pkgIndex.tcl: Bumped the tooltip version number to 1.6. * tooltip.tcl: Added support for ttk::notebook tabs; several further improvements; bumped the version number to 1.6. * tooltip.man: Documented the "-tab" option and added an example for it; extended the description of the "configure" subcommand; several further improvements; bumped the version number to 1.6. 2022-05-20 Emiliano Gavilan * tooltip.tcl, tooltip.man, tooltip.html: Add configure command. * pkgIndex.tcl: Bump the version number to 1.5. 2021-11-30 Csaba Nemethi * tooltip.tcl, tooltip.man: Minor improvements. 2021-11-27 Csaba Nemethi * pkgIndex.tcl: Bumped the tooltip version number to 1.4.7. * tooltip.tcl: Made sure that the "clear" subcommand will work for widgets having spaces in their names, too; several further improvements; bumped the version number to 1.4.7. * tooltip.man: Corrected the description of the "clear" subcommand; several further improvements; bumped the version number to 1.4.7. 2020-02-09 0.7 * * Released and tagged Tklib 0.7 ======================== * 2016-11-24 Arjen Markus * tooltip.tcl: Updated one of the error messages (the new option -- was missing) 2016-11-24 Arjen Markus * tooltip.man, pkgIndex.tcl: Increment to 1.4.6 * tooltip.tcl, tooltip.man: Apply patch by stwo to allow tooltips starting with a minus sign (ticket 3106443) 2013-03-25 Andreas Kupries * * Released and tagged Tklib 0.6 ======================== * 2009-01-21 Andreas Kupries * * Released and tagged Tklib 0.5 ======================== * 2008-12-01 Jeff Hobbs * tooltip.man, pkgIndex.tcl: Increment to 1.4.4 * tooltip.tcl (::tooltip::register): Added support for multiple items in -item (now -items) for listbox and canvas items, to allow canvas tagOrIds that return multiple items. 2008-11-04 Pat Thoyts * tooltip.tcl: Added support for listbox items. * tooltip.man: * pkgIndex.tcl: Incremented to 1.4.3 2008-08-08 Pat Thoyts * tooltip.tcl (::tooltip::tagTip): Cancel outstanding after events on tags when setting a new one to avoid visual glitches when moving the cursor across a set of tags (ie: tkchat userlist) 2008-07-14 Jeff Hobbs * pkgIndex.tcl: bump to 1.4.2. [Bug 2015992] * tooltip.tcl (::tooltip::enableTag, ::tooltip::enableCanvas): Protect bind enablers to only add themselves once. 2008-03-12 Jeff Hobbs * pkgIndex.tcl: bump to 1.4.1 * tooltip.tcl (::tooltip::show): check window exists before any other ops. [Bug 1879622] 2007-10-31 Jeff Hobbs * tooltip.tcl (::tooltip::clear): Withdraw the tooltip if we clear the current contained item. [Bug 1547729] * tooltip.tcl: added fading (default on for Win32/Aqua) of tooltip * tooltip.man: instead of just withdraw. [Bug 1641071] 2007-09-22 Pat Thoyts * tooltip.tcl (::tooltip::show): Left align the tooltip text * pkgIndex.tcl: (reported by Peter Caffin) * tooltip.man: Bumped to 1.4 Generally improved the manual to fix bug #1800296. 2007-05-18 Jeff Hobbs * tooltip.man, pkgIndex.tcl: bumped version to 1.3 * tooltip.tcl (::tooltip::show): Use late-binding msgcat (lazy translation) to support programs that allow on-the-fly l10n changes. Requires msgcat package (Tk uses this already). (poser) 2007-02-07 Pat Thoyts * tooltip.tcl: Added support for tooltips on text widget tags (useful for tkchat url links). Fixed menu tooltips. * tooltip.man: Added documentation. * pkgIndex.tcl: Incremented version to 1.2 2006-08-02 Jeff Hobbs * tooltip.tcl (::tooltip::show): better handle boundary case considering Tk's odd multi-monitor screen dimension handling. AS bug 48498. 2006-03-31 Andreas Kupries * tipstack.tcl (::tipstack::clearsub): Superfluous argument to call of 'clear' removed. 2005-11-21 Jeff Hobbs * tooltip.tcl (::tooltip::show): focus back to previous item, not the widget we are over. 2005-11-10 Andreas Kupries * * Released and tagged Tklib 0.4.1 ======================== * 2005-11-02 Andreas Kupries * * Released and tagged Tklib 0.4 ======================== * 2005-08-12 Andreas Kupries * tooltip.man: Added module/title descriptions to the manpage. 2005-08-11 Jeff Hobbs * tooltip.tcl (::tooltip::show): prevent aqua help focus theft 2005-04-29 Andreas Kupries * tooltip.man: Fixed syntax errors in the documentation. 2005-04-02 Aaron Faupell * initial import tcltk2/inst/tklibs/tooltip2.0.1/tooltip.tcl0000644000176200001440000005333515017041713020201 0ustar liggesusers# tooltip.tcl -- # # Balloon help # # Copyright (c) 1996-2007 Jeffrey Hobbs # Copyright (c) 2024 Emmanuel Frecon, Rene Zaumseil # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Initiated: 28 October 1996 package require Tk 8.5- #------------------------------------------------------------------------ # PROCEDURE # tooltip::tooltip # # DESCRIPTION # Implements a tooltip (balloon help) system # # ARGUMENTS # tooltip