tcltk2/0000755000176000001440000000000012445241312011503 5ustar ripleyuserstcltk2/TODO0000644000176000001440000000302212215417550012174 0ustar ripleyusers= tcltk2 To Do list * Despite I changed ::msgcat::mclocale to de, tk2chooseFont() is still in English (but it works for fr... why?) * tile.use(FALSE) after loading tile does not work with tk2chooseFont() * Rework tk2edit() [takes numeric only and return characters for the moment! rework also the button bar] * Add twapi, toolbar, tkdnd, datefield and swaplist * Rework the code to detect and work with ActiveState install under Linux * For the tips: select background color and font from style (same for bwidgets) * The package vignette * Tcl/Tk features to add: info/winfo update Idle tasks (update idletasks) bgerror correct handling of catch result => procedure for that error to generate tcl errors exit to end the application? see if there is no 'file' stuff that could be useful for R interp and after for delayed execution of code memory package pkg_mkIndex puts: write code from Tcl to the R console functions to manipulate Macintosh resources tclvars unknown A function to display the Tcl/Tk help and additional package help from R Use of the msgcat Tcl package easier definition and retrieval of bindings (+ keysyms) and events bitmap (2 colors) and image (+ IMG package? PPM/PGM and GIF by default) cursors experiment with focus -force! + lower/raise font manipulation functions + homogeneity of fonts between R and Tk styles must be handled with option! + tk_setPalette? GUI designer for fixed place of widgets tk/tkvars to retrieve various tk information * Make a demo section tcltk2/po/0000755000176000001440000000000012445051436012127 5ustar ripleyuserstcltk2/po/R-fr.po0000755000176000001440000001046212215417550013301 0ustar ripleyusersmsgid "" 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 utilise ne peut pas (encore) avoir d'arguments !" msgid "'name' must be a character string!" msgstr "'name' doit tre une chane de caractres !" msgid "'name' must be a character!" msgstr "'name' doit tre une chane de caractres !" msgid "Error when getting the value in the '%s' Tcl variable" msgstr "Erreur lors de la rcupration 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 spcifique 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 chane de caractres non nulle !" msgid "'service', 'topic' and 'command' must be character strings!" msgstr "'service', 'topic' et 'command' doivent tre des chanes de caractres !" msgid "'service' and 'topic' must be character strings!" msgstr "'service' et 'topic' doivent tre des chanes de caractres !" msgid "'item' must be character strings!" msgstr "'item' doit contenir des chanes de caractres !" 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 cration de la ressource d'icne ; '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 rcupration du pointeur d'icne pour un objet \"tclIcon\" !" msgid "Impossible to retrieve icon resource information!" msgstr "Impossible de rcuprer l'information de la ressource d'icne !" 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'icne, 'file' ou 'res' est erronn !" msgid "'value' must be numeric and of length one!" msgstr "'value' doit tre numrique et de longueur unitaire !" msgid "Error while changing default position of the icon!" msgstr "Erreur lors du changement de la position par dfaut de l'icne !" 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 fentre) !" msgid "'pos' must be numeric and of length one, or NULL!" msgstr "'pos' doit tre numrique 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 cration du callback pour cette icne !" msgid "Error getting the text associated with an icon!" msgstr "Erreur lors de la lecture du texte associ cette icne !" 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 icne !" 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-tcltk2.pot0000755000176000001440000000504312215417550014260 0ustar ripleyusersmsgid "" 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/inst/0000755000176000001440000000000012445051436012466 5ustar ripleyuserstcltk2/inst/po/0000755000176000001440000000000012445051436013104 5ustar ripleyuserstcltk2/inst/po/fr/0000755000176000001440000000000012445051436013513 5ustar ripleyuserstcltk2/inst/po/fr/LC_MESSAGES/0000755000176000001440000000000012445051436015300 5ustar ripleyuserstcltk2/inst/po/fr/LC_MESSAGES/R-tcltk2.mo0000755000176000001440000001060412215417550017241 0ustar ripleyusers#4/L !!?!a!,"1C-`0;,*("S=v;5/&6V52&0N1c.$$(-7;eG 'd % + 0 / +? +k < & 0 =, Hj 6 5 # DD g L :>NyN@?X9?=-,k)/3H&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 chanes de caractres !'leftmenu' doit tre un objet "tkwin" ou NULL !'name' doit tre une chane de caractres !'name' doit tre une chane de caractres !'pos' doit tre numrique 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 chanes de caractres !'service', 'topic' et 'command' doivent tre des chanes de caractres !'topic' doit tre une chane de caractres non nulle !'value' doit tre numrique et de longueur unitaire !'value' ne peut tre vide ou NULL !'win' n'est pas un objet "tkwin", ou un entier (handle de fentre) !Erreur lors de la cration de la ressource d'icne ; 'iconfile' est probablement corrompu ou incorrect Erreur lors de la rcupration du pointeur d'icne pour un objet "tclIcon" !Erreur lors de la lecture du texte associ cette icne !Erreur lors de la modification de la valeur contenue dans la variable Tcl '%s'Erreur lors de la rcupration de la valeur contenue dans la variable Tcl '%s'Erreur lors du changement de la position par dfaut de l'icne !Erreur lors de la modification du texte associ cette icne !Erreur lors de la cration du callback pour cette icne !Fichier '%s' introuvable !Impossible de rcuprer l'information de la ressource d'icne !La fonction utilise ne peut pas (encore) avoir d'arguments !Ceci est une fonction spcifique 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'icne, 'file' ou 'res' est erronn !'type' non reconnu !tcltk2/inst/CITATION0000644000176000001440000000145112215417550013622 0ustar ripleyuserscitHeader("To cite SciViews-R in publications use:") citEntry(entry="Manual", title = "SciViews-R: A GUI API for R", author = personList(as.person("Philippe Grosjean")), organization = "UMONS", address = "MONS, Belgium", year = version$year, url = "http://www.sciviews.org/SciViews-R", textVersion = paste("Grosjean, Ph. (", version$year, "). ", "SciViews: A GUI API for R. ", "UMONS, Mons, Belgium. ", "URL http://www.sciviews.org/SciViews-R.", sep = "") ) citFooter("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()"), "for citing R.") tcltk2/inst/Fonts.txt0000755000176000001440000000131112215417550014315 0ustar ripleyusers### Fonts TkDefaultFont # Default font for widgets TkClassicDefaultFont # Classic default font ### GUI elements TkMenuFont # Menus TkIconFont # Icon labels TkCaptionFont # Windows caption TkSmallCaptionFont # Small windows captions TkHeadingFont # Column headers TkStatusFont # Status bar TkTooltipFont # Tooltips ### Text TkBigTitleFont # A big title TkTitleFont # A title TkTextFont # Usual text (read on screen) TkTextStrongFont # Usual text strong (usually bold) TkTextEmphFont # Usual text emphasize (usually italic) TkFixedFont # Non prop text (code, ...) TkFixedStongFont # Non prop text strong (usually bold) TkFixedEmphFont # Non prop text emphasize (usually italic) tcltk2/inst/test.R0000644000176000001440000000122112215417550013562 0ustar ripleyusers### tcltk2 examples ### 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) ### combobox: to eliminate! ### choosefont ### TODO ### ctext ### TODO ### cursor ### TODO ### swaplist tclRequire("swaplist") tt <- tktoplevel() opts <- tclVar() sl <- tcl("swaplist::swaplist", tt, opts, 1:9, c(1, 3, 5)) cat("You choose:", tclvalue(opts), "\n") tcltk2/inst/gui/0000755000176000001440000000000012445051436013252 5ustar ripleyuserstcltk2/inst/gui/SciViews.ico0000755000176000001440000002043612215417547015516 0ustar ripleyusers(Vh~   00v( ]P0P??__0R"""/S "#"# 5?PSP35P0U0?( ʦ>]|$$HHll>](|2<FU$mHl*>?]T|i~$Hl>>]]||$Hl>*]?|Ti~ٓ$Hl>]|(2<FU$mHl>]|$$HHll>](|2<FUm$Hl*>?]T|i~$Hl>>]]||$Hl>*]?|Ti~ٓ$Hlڐ>]|(2<FUm$Hlʹ>]|$$HHll>]|(2<FU$mHl>*]?|Ti~$Hl>>]]||$Hl*>?]T|i~$Hlڐ>](|2<FUm$Hlʹ,,,999EEERRR___lllxxx¾0000000HHHHUSHVWHHHHHHXX00021/0541742( @UUP U p 70U30PUS?0_S_U3__3U3S0""""""""#""" r"""""u3" /3 r"""#5R """"3%P5_3U_?U3?p33_0 33U UPp0p?( @{{{Z{{jssjjs͔޽͜{bbŋŃŃ͔޽RAss޴Rs{դsbjRbb{jjլ11sJsAjZZJbbb1{1RZZAR9մA{Zsbjb1bR{{sJsJJbsbbbդ {{Ž{j))AbAA {jAs9 ͤJŤRŋJJbbZZRR9{{9Ŭ͜1jZ{Z{bbbJ11b޴ZZ{A BoxxB tWr[WrTjB3*Njrt<\< wlc < fcmKllY!m?3l3yF'!lm]|$$HHll>](|2<FU$mHl*>?]T|i~$Hl>>]]||$Hl>*]?|Ti~ٓ$Hl>]|(2<FU$mHl>]|$$HHll>](|2<FUm$Hl*>?]T|i~$Hl>>]]||$Hl>*]?|Ti~ٓ$Hlڐ>]|(2<FUm$Hlʹ>]|$$HHll>]|(2<FU$mHl>*]?|Ti~$Hl>>]]||$Hl*>?]T|i~$Hlڐ>](|2<FUm$Hlʹ,,,999EEERRR___lllxxx⿿¿10001111111111RRRRTTTSSR\=\1UVVVVUSZH<;;׎rDƔi(;ԓ1iME3U2m NT0xFTp>,Y^; n!m_8``x1*P"P ȞsLt2bK-!Xpc, 0ϴ7FZ I z .|:lSRBq(TO5x 2qC{ 5W'\x(=Y)LE 10| ^$l"\(^aihK( @FY=`Qs @܈#t* 39`Ė;l`GN15)uL`3DqBX9$dQEuP!jjR94U\(bM7{7+2l:P+@ᩄHbQ/w `6%0<\'Cผs1UA~YS!m(Y suЍwy! mNj [j*W>8 S.7Y-N8H#Smj6+yH'T(r L犕z5@vlR,1;$B[*@lY ,t2.ݬ꾮ŀ@ =3AK2qlX@ m$! cmvm<D 8d6 '33n>X_"s_ =,GeAQL=٬7)"l@> r "`C dzͳe+ 5! > G8ф#thD Nac+c|s@N" H4h r>tD-8E>'0QȒժ R%'4DpƼdbw3@F c1B> `HB {' " B7:vdy'*aF z8lOA B<\6:M Eu~$Ă!e f` bFH0Lh!A6 wp tT(1q%| Pr0Dēe(&P2q )p@@%XAL k怉ֱxC(y cB"@b  )`)yj/Y\԰ %B:% L0 S+)46R@ pB  A M1D Ked&^ <R-*@K1EI^AM6\*䫁L`Өz؜J2uf%gul.WM=ؒ%j~X%Ar bZaI^[_ih 3υ ˨Ry?/ӡsI/}_ 9l8Vdo NChN%%c7Z[s'M3!x@!X.r˳@p M@8$Chi&ݢA^ls 8ONr@+8da%7@ʼn/`"w($&.+ fd *K#W~s8{; /lc!D +UE)a n 'P  $c:/M v9$*А2Mނ p+ri$jd63 t#Ё^P g= #|+I<+ Pqz!X]:#A# QV0Y{>.pk [`s`#$Dp#q N:#h#@Bl1h&5+؛ؑ P\Z^ ^8B#TA# a8CQoRBOd\ '`؈+p.5=DOҗ;PI@;tcltk2/inst/tklibs/0000755000176000001440000000000012445051436013756 5ustar ripleyuserstcltk2/inst/tklibs/widget3.0/0000755000176000001440000000000012445051436015462 5ustar ripleyuserstcltk2/inst/tklibs/widget3.0/superframe.tcl0000644000176000001440000000763512215417550020350 0ustar ripleyusers# -*- tcl -*- # # superframe.tcl - # # Superframe widget - enhanced labelframe widget # # RCS: @(#) $Id: superframe.tcl,v 1.3 2006/09/29 16:25:07 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 # We could do this without tile ... but let's not #package require tile # ### ######### ########################### ## 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 tcltk2/inst/tklibs/widget3.0/stext.tcl0000644000176000001440000000405512215417550017337 0ustar ripleyusers# -*- 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/widget3.0/example.R0000644000176000001440000000243612215417550017243 0ustar ripleyusers# Test of widget 3.0 # The calendar widget (impossible to load) tclRequire("widget::calendar") tt <- tktoplevel() db <- tkwidget(tt, "widget::calendar") tkpack(db, fill = "both", expand = 1) # The menuentry widget (OK) tclRequire("widget::menuentry") tt <- tktoplevel() me <- tkwidget(tt, "widget::menuentry") mnu <- tkmenu(me, tearoff = 0) foo <- tclVar() tkadd(mnu, "radiobutton", label = "Name", variable = foo, value = "name") tkadd(mnu, "radiobutton", label = "Abstract", variable = foo, value = "abstract") tkadd(mnu, "separator") tkadd(mnu, "radiobutton", label = "Name and Abstract", variable = foo, value = "name abstract") tkconfigure(me, menu = mnu) tkpack(me, fill = "x", expand = 1, padx = 4, pady = 4) # Change the selection in the menu, and then: tclvalue(foo) # The panelframe (does not work!?) tclRequire("widget::panelframe") tt <- tktoplevel() pf <- tkwidget(tt, "widget::panelframe", text = "My Panel") sf <- tkframe(pf, padx = 4, pady = 4) txt <- tktext(sf) tkpack(txt, fill = "both", expand = 1) tcl(pf, "setwidget", sf) tkpack(sf, fill = "both", expand = 1, padx = 4, pady = 4) # The superframe (what is this?) tclRequire("widget::superframe") tt <- tktoplevel() sf <- tkwidget(tt, "widget::superframe", text = "Superframe:") tkpack(sf) tkpack(tk2button(sf, text = "A button")) tcltk2/inst/tklibs/widget3.0/pkgIndex.tcl0000644000176000001440000000207112215417550017735 0ustar ripleyusers# Tcl Package Index File 1.0 if {![llength [info commands ::tcl::pkgindex]]} { proc ::tcl::pkgindex {dir bundle bundlev packages} { set allpkgs [list] foreach {pkg ver file} $packages { lappend allpkgs [list package require $pkg $ver] package ifneeded $pkg $ver [list source [file join $dir $file]] } if {$bundle != ""} { lappend allpkgs [list package provide $bundle $bundlev] package ifneeded $bundle $bundlev [join $allpkgs \n] } return } } if {![package vsatisfies [package provide Tcl] 8.4]} {return} ::tcl::pkgindex $dir widget::all 1.2 { widget 3.0 widget.tcl widget::calendar 0.9 calendar.tcl widget::dateentry 0.91 dateentry.tcl widget::dialog 1.3 dialog.tcl widget::menuentry 1.0 mentry.tcl widget::panelframe 1.1 panelframe.tcl widget::ruler 1.1 ruler.tcl widget::screenruler 1.2 ruler.tcl widget::scrolledtext 1.0 stext.tcl widget::scrolledwindow 1.2 scrollw.tcl widget::statusbar 1.2 statusbar.tcl widget::superframe 1.0 superframe.tcl widget::toolbar 1.2 toolbar.tcl } tcltk2/inst/tklibs/widget3.0/widget_toolbar.man0000644000176000001440000000244312215417550021165 0ustar ripleyusers[comment {-*- tcl -*- doctools manpage}] [manpage_begin widget_toolbar n 3.0] [moddesc {widget::toolbar Megawidget}] [titledesc {widget::toolbar Megawidget}] [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 opt] [opt_def -ipad] [opt_def -pad] [opt_def -separator] [list_end] [section "ITEM OPTIONS"] [list_begin opt] [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] }] [keywords megawidget snit widget] [manpage_end] tcltk2/inst/tklibs/widget3.0/example.tcl0000644000176000001440000000024312215417550017616 0ustar ripleyusers#package require widget::superframe ; # or widget::all source ./widget.tcl source ./superframe.tcl pack [widget::superframe .f -type separator -text "SuperFrame:"]tcltk2/inst/tklibs/widget3.0/dialog.tcl0000644000176000001440000003345412215417550017434 0ustar ripleyusers# -*- tcl -*- # # dialog.tcl - # # Generic dialog widget (themed) # # RCS: @(#) $Id: dialog.tcl,v 1.22 2009/01/09 05:46:12 andreas_kupries Exp $ # # 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 tile 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} 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 tcltk2/inst/tklibs/widget3.0/dateentry.tcl0000755000176000001440000002207012215417550020167 0ustar ripleyusers# -*- 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. # # RCS: @(#) $Id: dateentry.tcl,v 1.3 2008/11/14 03:40:23 hobbs Exp $ # # 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 # # 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 if {![package vsatisfies [package provide Tk] 8.5]} { package require tile } 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 {} delegate option -highlightcolor to calendar delegate option -firstday to calendar component dropbox component calendar variable waitVar variable formattedDate variable rawDate variable startOnMonday 1 constructor args { ::widget::createdateentryLayout installhull using ttk::entry -style dateentry bindtags $win [linsert [bindtags $win] 1 TDateEntry] $self MakeCalendar $self configurelist $args set now [clock seconds] set x [clock format $now -format "%d/%m%/%Y"] set rawDate [clock scan "$x 00:00:00" -format "%d/%m%/%Y %H:%M:%S"] set formattedDate [clock format $rawDate -format $options(-dateformat)] $hull configure -state normal $hull delete 0 end $hull insert end $formattedDate $hull configure -state readonly } method C-passtocalendar {option value} { set options($option) $value $calendar configure $option $value } 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 } else { tk::unsupported::MacWindowStyle style $dropbox \ help {noActivates hideOnSuspend} } wm transient $dropbox [winfo toplevel $win] wm group $dropbox [winfo parent $win] 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 } }] set calendar $dropbox.calendar widget::calendar $calendar -command [mymethod DateChosen] \ -textvariable [myvar formattedDate] \ -dateformat $options(-dateformat) \ -font $options(-font) \ -borderwidth 1 -relief solid pack $calendar -expand 1 -fill both return $dropbox } method post { args } { # XXX should we reset date on each display? if {![winfo exists $dropbox]} { $self MakeCalendar } set waitVar 0 foreach {x y} [$self PostPosition] { break } wm geometry $dropbox "+$x+$y" wm deiconify $dropbox raise $dropbox if {[tk windowingsystem] ne "aqua"} { tkwait visibility $dropbox } ttk::globalGrab $dropbox focus -force $calendar return tkwait variable [myvar waitVar] $self unpost } method unpost {args} { ttk::releaseGrab $dropbox wm withdraw $dropbox } 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] } method DateChosen { args } { upvar 0 $options(-textvariable) date set waitVar 1 set date $formattedDate set rawDate [clock scan $formattedDate -format $options(-dateformat)] if { $options(-command) ne "" } { uplevel \#0 $options(-command) $formattedDate $rawDate } $self unpost $hull configure -state normal $hull delete 0 end $hull insert end $formattedDate $hull configure -state readonly } } # 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 } package provide widget::dateentry 0.91 ############## # TEST CODE ## ############## if { [info script] eq $argv0 } { proc getDate { args } { puts [info level 0] puts "DATE $::DATE" update } proc dateTrace { args } { puts [info level 0] } # 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 trace add variable ::DATE write dateTrace set ::DATE 1 puts [$end get] } tcltk2/inst/tklibs/widget3.0/panelframe.tcl0000644000176000001440000001475712215417550020314 0ustar ripleyusers# -*- 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.5 2008/06/17 20:28:27 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 #package require tile 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.0/toolbar.tcl0000644000176000001440000001737712215417550017645 0ustar ripleyusers# -*- tcl -*- # # toolbar - /snit::widget # Manage items in a toolbar. # # RCS: @(#) $Id: toolbar.tcl,v 1.11 2007/06/21 01:59:28 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 tile #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 tcltk2/inst/tklibs/widget3.0/calendar.tcl0000755000176000001440000003347612215417550017755 0ustar ripleyusers# -*- tcl -*- # # calendar.tcl - # # Calendar widget drawn on a canvas. # Adapted from Suchenwirth code on the wiki. # # RCS: @(#) $Id: calendar.tcl,v 1.2 2008/12/11 18:07:20 hobbs Exp $ # # 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" # # All other options to canvas # # Methods # $path get => selected date # 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 # showpast not currently correct option -showpast -default 1 -type {snit::boolean} \ -configuremethod C-refresh 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] set x [clock format $now -format "%d/%m%/%Y"] set now [clock scan "$x 00:00:00" -format "%d/%m%/%Y %H:%M:%S"] foreach {data(day) data(month) data(year)} \ [clock format $now -format "%d %m %Y"] { break } # Binding for the 'day' tagged items $win bind day <1> [mymethod invoke] $self configurelist $args $self reconfigure $self refresh } method C-font {option value} { set options($option) $value $self reconfigure set fullrefresh 1 $self refresh } method C-refresh {option value} { set options($option) $value $self refresh } method C-textvariable {option value} { set options($option) $value if {$value ne "" && [info exists $value]} { set tmp [set $value] if {$tmp eq ""} { return } set date [clock scan $tmp -format $options(-dateformat)] foreach {data(selday) data(selmonth) data(selyear)} \ [clock format $date -format "%d %m %Y"] { break } $self refresh } } 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" } } } method adjust {dmonth dyear} { incr data(year) $dyear incr data(month) $dmonth 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} $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 -1]; # << $self cbutton [expr {$xs*2}] $pad [expr {-$xs/1.5}] [mymethod adjust -1 0]; # < set lxs [expr {$winw - $xs - 2}] $self cbutton $lxs $pad $xs [mymethod adjust 0 1]; # >> incr lxs -$xs $self cbutton $lxs $pad [expr {$xs/1.5}] [mymethod adjust 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 $d $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 "Today is [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 invoke {} { set item [$hull find withtag current] set data(day) [$hull itemcget $item -text] 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 {$options(-textvariable) ne {}} { set $options(-textvariable) $fmtdate } if {$options(-command) ne {}} { # pass single arg of formatted date chosen uplevel \#0 $options(-command) [list $fmtdate] } $self refresh } 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} 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} 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} mn,de { . Januar Februar Mrz April Mai Juni Juli August September Oktober November Dezember } weekdays,de {So Mo Di Mi Do Fr Sa} mn,en { . January February March April May June July August September October November December } weekdays,en {Su Mo Tu We Th Fr Sa} mn,es { . Enero Febrero Marzo Abril Mayo Junio Julio Agosto Septiembre Octubre Noviembre Diciembre } weekdays,es {Do Lu Ma Mi Ju Vi Sa} mn,fr { . Janvier Fvrier Mars Avril Mai Juin Juillet Aot Septembre Octobre Novembre Dcembre } weekdays,fr {Di Lu Ma Me Je Ve Sa} mn,gr { . ?????? ??????? ??? ???? ?? ???? ???? ??? ?????? ????? ????? ?????? } weekdays,gr { ? T? ?? ?? ? ???} mn,he { . ? ??? ?? ?? ? ??? ?? ? ?? } weekdays,he {?? ? ?? ?? ? ?? ??} mn,it { . Gennaio Febraio Marte Aprile Maggio Giugno Luglio Agosto Settembre Ottobre Novembre Dicembre } weekdays,it {Do Lu Ma Me Gi Ve Sa} format,ja {%Y\u5e74 %m\u6708} weekdays,ja {\u65e5 \u6708 \u706b \u6c34 \u6728 \u91d1 \u571f} mn,nl { . januari februari maart april mei juni juli augustus september oktober november december } weekdays,nl {Zo Ma Di Wo Do Vr Za} 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 } 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} mn,pt { . Janeiro Fevereiro Mar\u00E7o Abril Maio Junho Julho Agosto Setembro Outubro Novembro Dezembro } weekdays,pt {Dom Seg Ter Qua Qui Sex Sab} 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} mn,fi { . Tammikuu Helmikuu Maaliskuu Huhtikuu Toukokuu Keskuu Heinkuu Elokuu Syyskuu Lokakuu Marraskuu Joulukuu } weekdays,fi {Ma Ti Ke To Pe La Su} 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} } } package provide widget::calendar 0.9 tcltk2/inst/tklibs/widget3.0/statusbar.tcl0000644000176000001440000001755412215417550020210 0ustar ripleyusers# -*- tcl -*- # # statusbar.tcl - # Create a status bar Tk widget # # RCS: @(#) $Id: statusbar.tcl,v 1.7 2007/06/21 01:59:40 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 package require tile 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 tcltk2/inst/tklibs/widget3.0/widget.man0000644000176000001440000000272312215417550017444 0ustar ripleyusers[comment {-*- tcl -*- doctools manpage}] [manpage_begin widget n 3.0] [moddesc {Megawidget package}] [titledesc {Megawidget package}] [require Tcl 8.4] [require Tk 8.4] [require widget [opt 3.0]] [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:"] }] [keywords megawidget snit widget] [manpage_end] tcltk2/inst/tklibs/widget3.0/ruler.tcl0000644000176000001440000004432712215417550017327 0ustar ripleyusers# -*- tcl -*- # # ruler.tcl # # ruler widget and screenruler dialog # # Copyright (c) 2005 Jeffrey Hobbs. All Rights Reserved. # # RCS: @(#) $Id: ruler.tcl,v 1.13 2008/02/21 20:11:16 hobbs Exp $ # ### # 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} { 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.1 package provide widget::screenruler 1.2 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.0/ChangeLog0000644000176000001440000002335712215417550017244 0ustar ripleyusers2009-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.0/widget_calendar.man0000644000176000001440000000376112215417550021300 0ustar ripleyusers[comment {-*- tcl -*- doctools manpage}] [manpage_begin widget_calendar n 0.9] [moddesc {widget::calendar Megawidget}] [titledesc {widget::calendar Megawidget}] [require Tcl 8.4] [require Tk 8.4] [require widget [opt 3.0]] [description] This package provides a calendar megawidget (snidget). It makes use of the Tile/Ttk themed widget set. [para] [list_begin definitions] [call [cmd widget::calendar] [arg pathname] [opt options]] [list_end] [section "WIDGET OPTIONS"] [nl] [list_begin opt] [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. [nl] Supported languages: en, de, fr, it, es, pt, ru, sv, zh, fi [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] [arg what] [nl] Returns 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. [section EXAMPLE] [example { package require widget::calendar ; # or widget::all set t [widget::calendar .t] pack $t -fill x -expand 1 }] [keywords megawidget snit widget] [manpage_end] tcltk2/inst/tklibs/widget3.0/widget.tcl0000644000176000001440000001020512215417550017445 0ustar ripleyusers# -*- tcl -*- # # widget.tcl -- # # megawidget package that uses snit as the object system (snidgets) # # Copyright (c) 2005 Jeffrey Hobbs # # RCS: @(#) $Id: widget.tcl,v 1.5 2006/09/29 16:25:07 hobbs Exp $ # package require Tk 8.4 package require snit #package provide Widget 3.0 ; # 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 } 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 { if {![string is integer -strict $val] || ([incr i] > $range)} { return -code error "$option requires an 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.0 tcltk2/inst/tklibs/widget3.0/scrollw.tcl0000644000176000001440000001663612215417550017665 0ustar ripleyusers# -*- tcl -*- # # scrollw.tcl - # # Scrolled widget # # RCS: @(#) $Id: scrollw.tcl,v 1.14 2007/06/20 23:42:41 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 package require tile 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 tcltk2/inst/tklibs/widget3.0/mentry.tcl0000644000176000001440000002173012215417550017505 0ustar ripleyusers# -*- tcl -*- # # mentry.tcl - # # MenuEntry widget # # RCS: @(#) $Id: mentry.tcl,v 1.6 2007/04/10 18:15:40 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 #package require tile 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 tcltk2/inst/tklibs/snit1.0/0000755000176000001440000000000012445051436015152 5ustar ripleyuserstcltk2/inst/tklibs/snit1.0/license.txt0000644000176000001440000000413712215417550017340 0ustar ripleyusersThis 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/snit1.0/snit.man0000644000176000001440000021410412215417550016624 0ustar ripleyusers[comment {-*- tcl -*- doctools manpage}] [manpage_begin snit n 1.0] [copyright {2003-2005, by William H. Duquette}] [moddesc {Snit's Not Incr Tcl, OO system}] [titledesc {Snit's Not Incr Tcl}] [require Tcl 8.4] [require snit [opt 1.0]] [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 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. [nl] The type name is then a command that is used to create objects of the new type, along with other activities. [nl] 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 list of keyword/value pairs; it will be assigned to the variable in the manner of [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]. [nl] 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. [nl] If the [arg name] consists of two or more tokens, Snit handles it specially: [example { typemethod {a b} {} { ... } }] The following two calls to this type method are equivalent: [example { $type {a b} $type a b }] In other words, [const a] becomes a subcommand of [var \$type], and [const b] becomes a subcommand of [const a]. This makes it possible to define a hierarchical command structure; see [cmd method], below, for more examples. [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}]. [nl] 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. [nl] A type may define at most one type constructor. [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 list of keyword/value pairs; it will be assigned to the variable in the manner of [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. [nl] 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]. [nl] An instance method defined in this way is said to be [term {locally defined}]. [nl] 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. [nl] If the [arg name] consists of two or more tokens, Snit handles it specially: [example { method {a b} {} { ... } }] The following two calls to this type method are equivalent: [example { $self {a b} $self a b }] In other words, [const a] becomes a subcommand of [var \$self], and [const b] becomes a subcommand of [const a]. This makes it possible to define a hierarchical command structure. For example, [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. [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. [nl] An option defined in this way is said to be [term {locally defined}]. [nl] 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. [nl] 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. [nl] The [cmd option] statement may include the following options: [list_begin definitions] [lst_item "[const -default] [arg defvalue]"] Defines the option's default value; the option's default value will be "" otherwise. [lst_item "[const -readonly] [arg flag]"] The [arg flag] can be any Boolean value recognized by Tcl. If [arg flag] is true, then the option is readonly--it can only be set using [method configure] or [method configurelist] at creation time, i.e., in the type's constructor. [lst_item "[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]. [nl] 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]. [lst_item "[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. [nl] 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]. [lst_item "[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. [nl] 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. [nl] 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]. [nl] 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. [nl] If the [arg definition] defines neither a constructor nor any options, the default constructor is defined as follows: [example { constructor {} {} }] [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. [nl] 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]. [call [cmd proc] [arg name] [arg args] [arg body]] Defines a new Tcl procedure in the type's namespace. [nl] 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. [nl] Although they are not implicitly defined for procs, the argument names [const type], [const self], and [const win] should be avoided. [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. [nl] 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" }] [nl] A method cannot be both locally defined and delegated. [nl] [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. [nl] 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. [nl] Substitutions: [list_begin definitions] [lst_item [const %%]] This is replaced with a single "%". Thus, to pass the string "%c" to the command as an argument, you'd write "%%c". [lst_item [const %c]] This is replaced with the named component's command. [lst_item [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]. [lst_item [const %M]] This is replaced by the method [arg name]; if the [arg name] consists of multiple tokens, they are joined by space characters. [lst_item [const %j]] This is replaced by the method [arg name]; if the [arg name] consists of multiple tokens, they are joined by underscores ("_"). [lst_item [const %t]] This is replaced with the fully qualified type name. [lst_item [const %n]] This is replaced with the name of the instance's private namespace. [lst_item [const %s]] This is replaced with the name of the instance command. [lst_item [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. [nl] 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 these [cmd onconfigure] and [cmd oncget] handlers were defined, where [arg name] is the option name from the [arg namespec]: [example { onconfigure name {value} { $comp configure name $value } oncget name { return [$comp cget name] } }] If the [const as] clause is specified, then the [arg target] option name is used in place of [arg name]. [nl] The form [cmd "delegate option *"] 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., option names that will not be so delegated. [nl] Warning: options can only be delegated to a component if it supports the [method configure] and [method cget] instance methods. [nl] Note that an option cannot be both locally defined and delegated. [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. [nl] 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. [nl] 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" }] [nl] 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. [nl] 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. [nl] Substitutions: [list_begin definitions] [lst_item [const %%]] This is replaced with a single "%". Thus, to pass the string "%c" to the command as an argument, you'd write "%%c". [lst_item [const %c]] This is replaced with the named type component's command. [lst_item [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]. [lst_item [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. [lst_item [const %j]] This is replaced by the type method [arg name]; if the [arg name] consists of multiple tokens, they are joined by underscores ("_"). [lst_item [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. [nl] [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. [nl] 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. [nl] 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. [nl] 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] [lst_item "[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. [lst_item "[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. [lst_item "[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. [lst_item "[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. [nl] This pragma and [const -hasinstances] cannot both be set false. [lst_item "[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. [nl] This pragma and [const -hastypemethods] cannot both be set false. [lst_item "[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. [lst_item "[const -simpledispatch] [arg flag]"] This pragma is intended to make simple, heavily-used abstract data types (e.g., stacks and queues) more efficient. [nl] 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 bullet] [bullet] Methods cannot be delegated. [bullet] [cmd uplevel] and [cmd upvar] do not work as expected: the caller's scope is two levels up rather than one. [bullet] 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. [nl] 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. [nl] 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 bullet] [bullet] 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. [nl] 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]. [bullet] 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) or [const toplevel]. [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]. [nl] Note that in general it is not possible to change the [emph {widget class}] of a [cmd snit::widgetadaptor]'s hull widget. [nl] 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. [nl] 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. [nl] 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. [nl] 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. [nl] [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. [nl] 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. [nl] Furthermore, 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 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. [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. [nl] 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. [nl] For [cmd snit::widget]s and [cmd snit::widgetadaptor]s, [arg name] must be a valid widget name; the method returns the widget name. [nl] 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. [nl] 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. [nl] 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. [nl] 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. [nl] 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 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. [nl] 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 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. [nl] 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 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. [nl] 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. [nl] 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. [nl] 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. [nl] 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. [nl] [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. [nl] 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. [nl] 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 instance's type's type methods. 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. [nl] 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 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. [nl] If [arg pattern] is given, it's used as a [cmd {string match}] pattern; only names that match the pattern are returned. [nl] 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 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. [nl] If [arg pattern] is given, it's used as a [cmd {string match}] pattern; only names that match the pattern are returned. [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. [nl] [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. [nl] 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. [nl] [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. [nl] 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. [nl] 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. [nl] 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. [nl] It's generally clearest to define all instance variables in the type definition, and omit declaring them in methods and so forth. [nl] 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. [nl] 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. [nl] 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. [nl] 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 bullet] [bullet] If the [cmd snit::widget]'s default widget class is not what is desired, set it explicitly using [cmd widgetclass] in the widget definition. [bullet] When defining or delegating options, specify the resource and class names explicitly when if the defaults aren't what you want. [bullet] Use [cmd {installhull using}] to install the hull for [cmd snit::widgetadaptor]s. [bullet] 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] Note that only [cmd frame] and [cmd toplevel] widgets allow the user to change the widget class name, which is why they are the only allowable hull types for [cmd snit::widget]s. [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 is a [cmd frame] or [cmd toplevel], 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 bullet] [bullet] Builds a list of the options explicitly included in the [cmd install] command -- in this case, [option -foreground]. [bullet] Queries the option database for all options delegated explicitly to the named component. [bullet] 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. [bullet] 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] [section CAVEATS] Please understand that while Snit is well-tested and fairly stable, it is still evolving (we have not yet reached Snit 1.0). If you have problems, find bugs, or new ideas you are hereby cordially invited to submit a report of your problem, bug, or idea at the SourceForge trackers for tcllib, which can be found at [uri http://sourceforge.net/projects/tcllib/]. The relevant category is [emph snit]. [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 bullet] [bullet] Error stack traces returned by Snit are extremely ugly and typically contain far too much information about Snit internals. [bullet] Also see the SourceForge Trackers at [uri http://sourceforge.net/projects/tcllib/], category [emph snit]. [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, and Brian Griffin. If I've forgotten anyone, my apologies; let me know and I'll add your name to the list. [keywords class {object oriented} object C++] [keywords Snit type {Incr Tcl} BWidget] [keywords widget adaptors {widget adaptors} {mega widget}] [manpage_end] tcltk2/inst/tklibs/snit1.0/pkgIndex.tcl0000644000176000001440000000020612215417550017423 0ustar ripleyusersif {![package vsatisfies [package provide Tcl] 8.4]} {return} package ifneeded snit 1.0 \ [list source [file join $dir snit.tcl]] tcltk2/inst/tklibs/snit1.0/snit.tcl0000644000176000001440000034721412215417550016644 0ustar ripleyusers#----------------------------------------------------------------------- # TITLE: # snit.tcl # # AUTHOR: # Will Duquette # # DESCRIPTION: # Snit's Not Incr Tcl, a simple object system in Pure Tcl. # # Copyright (C) 2003-2005 by William H. Duquette # This code is licensed as described in license.txt. # #----------------------------------------------------------------------- package provide snit 1.0 #----------------------------------------------------------------------- # 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} # If true, get a pretty, fixed-up stack trace. Otherwise, get raw # stack trace. # NOTE: Not Yet Implemented variable prettyStackTrace 1 } #----------------------------------------------------------------------- # 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 eq "" && [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 eq ""} { # Create the compiler's interpreter set compiler [interp create] # Initialize the interpreter $compiler eval { # Load package information # TBD: see if this can be moved outside. 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) 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% } %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) } } # 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 # 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 either "frame" or "toplevel" if {"frame" != $name && "toplevel" != $name} { error "invalid hulltype \"$name\", should be \"frame\" or \"toplevel\"" } 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 } # 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 } -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" } # Next, add variable declarations to body: set body "%TVARDECS%%IVARDECS%\n$body" 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$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$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]" } 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 && [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 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 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 {[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 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 {[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} { set first [string index $text 0] set rest [string range $text 1 end] return "[string toupper $first]$rest" } # 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) && [info commands $name] ne ""} { 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, to the basename of # the $type with an initial upper case letter. if {!$Snit_info(isWidgetAdaptor)} { # FIRST, determine the class name if {"" == $Snit_info(widgetclass)} { set Snit_info(widgetclass) \ [::snit::Capitalize [namespace tail $type]] } # NEXT, create the widget set self $name package require Tk ${type}::installhull using \ $Snit_info(hulltype) -class $Snit_info(widgetclass) # 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 # 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 {[info commands $candidate] eq ""} { 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} { # 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 {[info command $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 } # 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 {$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} { return [list 1] } # NEXT, build the substitution list set subList [list \ %% % \ %t $type \ %M $method \ %m [lindex $method end] \ %j [join $method _]] 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 } 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 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 \"$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 {$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 {"" == [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) && $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 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] { if {![namespace exists $selfns]} { continue } upvar ${selfns}::Snit_instance obj if {$Snit_info(isWidget)} { destroy $obj } else { if {"" != [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) eq ""} { 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) 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, 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 ""} { 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) eq ""} { 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) 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 { 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 -glob $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 -glob $pattern] { if {[lsearch -exact $result $name] == -1} { lappend result $name } } } return $result } # 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] { 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 { 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 -glob $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 -glob $pattern] { if {[lsearch -exact $result $name] == -1} { lappend result $name } } } return $result } # $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 ""} { 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 } tcltk2/inst/tklibs/snit1.0/dictionary.txt0000644000176000001440000001151412215417550020060 0ustar ripleyusersLast 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_typeMethodCache Array(typemethod name) = cached command Used in typemethod dispatch. 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. 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). 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_methodCache Array(method name) = cached command Used during method dispatch. 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/snit1.0/snitfaq.html0000644000176000001440000045471312215417550017521 0ustar ripleyusers snitfaq - Snit's Not Incr Tcl, OO system

snitfaq(n) 1.0 snit "Snit's Not Incr Tcl, OO system"

NAME

snitfaq - Snit Frequently Asked Questions

TABLE OF CONTENTS

    TABLE OF CONTENTS
    DESCRIPTION
    OVERVIEW
        What is this document?
        What is Snit?
        What version of Tcl does Snit require?
        Where can I download Snit?
        What are Snit's goals?
        How is Snit different from other OO frameworks?
        What can I do with Snit?
    OBJECTS
        What is an object?
        What is an abstract data type?
        What kinds of abstract data types does Snit provide?
        What is a snit::type?
        What is a snit::widget?
        What is a snit::widgetadaptor?
        How do I create an instance of a snit::type?
        How do I refer to an object indirectly?
        How can I generate the object name automatically?
        Can types be renamed?
        Can objects be renamed?
        How do I destroy a Snit object?
    INSTANCE METHODS
        What is an instance method?
        How do I define an instance method?
        How does a client call an instance method?
        How does an instance method call another instance method?
        Are there any limitations on instance method names?
        How do I make an instance method private?
        Are there any limitations on instance method arguments?
        What implicit arguments are passed to each instance method?
        What is $type?
        What is $self?
        What is $selfns?
        What is $win?
        How do I pass an instance method as a callback?
        How do I delegate instance methods to a component?
    INSTANCE VARIABLES
        What is an instance variable?
        How is a scalar instance variable defined?
        How is an array instance variable defined?
        Are there any limitations on instance variable names?
        Do I need to declare my instance variables in my methods?
        How do I pass an instance variable's name to another object?
        How do I make an instance variable public?
    OPTIONS
        What is an option?
        How do I define an option?
        How can a client set options at object creation?
        How can a client retrieve an option's value?
        How can a client set options after object creation?
        How should an instance method access an option value?
        How can I make an option read-only?
        How can I catch accesses to an option's value?
        What is a -cgetmethod?
        How can I catch changes to an option's value?
        What is a -configuremethod?
        How can I validate an option's value?
        What is a -validatemethod?
    TYPE VARIABLES
        What is a type variable?
        How is a scalar type variable defined?
        How is an array-valued type variable defined?
        Are there any limitations on type variable names?
        Do I need to declare my type variables in my methods?
        How do I pass a type variable's name to another object?
        How do I make a type variable public?
    TYPE METHODS
        What is a type method?
        How do I define a type method?
        How does a client call a type method?
        Are there any limitations on type method names?
        How do I make a type method private?
        Are there any limitations on type method arguments?
        How does an instance or type method call a type method?
        How do I pass a type method as a callback?
    PROCS
        What is a proc?
        How do I define a proc?
        Are there any limitations on proc names?
        How does a method call a proc?
        How can I pass a proc to another object as a callback?
    TYPE CONSTRUCTORS
        What is a type constructor?
        How do I define a type constructor?
    CONSTRUCTORS
        What is a constructor?
        How do I define a constructor?
        What does the default constructor do?
        Can I choose a different set of arguments for the constructor?
        Are there any limitations on constructor arguments?
        Is there anything special about writing the constructor?
    DESTRUCTORS
        What is a destructor?
        How do I define a destructor?
        Are there any limitations on destructor arguments?
        What implicit arguments are passed to the destructor?
        Must components be destroyed explicitly?
        Is there any special about writing a destructor?
    COMPONENTS
        What is a component?
        How do I declare a component?
        How is a component named?
        Are there any limitations on component names?
        What is an owned component?
        What does the install command do?
        Must owned components be created in the constructor?
        Are there any limitations on component object names?
        Must I destroy the components I own?
        Can I expose a component's object command as part of my interface?
        How do I expose a component's object command?
    TYPE COMPONENTS
        What is a type component?
        How do I declare a type component?
        How do I install a type component?
        Are there any limitations on type component names?
    DELEGATION
        What is delegation?
        How can I delegate a method to a component object?
        Can I delegate to a method with a different name?
        Can I delegate to a method with additional arguments?
        Can I delegate a method to something other than an object?
        How can I delegate a method to a type component object?
        How can I delegate a type method to a type component object?
        How can I delegate an option to a component object?
        Can I delegate to an option with a different name?
        How can I delegate any unrecognized method or option to a component object?
        How can I delegate all but certain methods or options to a component?
    WIDGETS
        What is a snit::widget?
        How do I define a snit::widget?
        How do snit::widgets differ from snit::types?
        What is a hull component?
        How can I set the hull type for a snit::widget?
        How should I name widgets which are components of a snit::widget?
    WIDGET ADAPTORS
        What is a snit::widgetadaptor?
        How do I define a snit::widgetadaptor?
        Can I adapt a widget created elsewhere in the program?
        Can I adapt another megawidget?
    THE TK OPTION DATABASE
        What is the Tk option database?
        Do snit::types use the Tk option database?
        What is my snit::widget's widget class?
        What is my snit::widgetadaptor's widget class?
        What are option resource and class names?
        What are the resource and class names for my megawidget's options?
        How does Snit initialize my megawidget's locally-defined options?
        How does Snit initialize delegated options?
        How does Snit initialize options delegated to the hull?
        How does Snit initialize options delegated to other components?
        What happens if I install a non-widget as a component of widget?
    ENSEMBLE COMMANDS
        What is an ensemble command?
        How can I create an ensemble command using Snit?
        How can I create an ensemble command using an instance of a snit::type?
        How can I create an ensemble command using a snit::type?
    PRAGMAS
        What is a pragma?
        How do I set a pragma?
        How can I get rid of the "info" type method?
        How can I get rid of the "destroy" type method?
        How can I get rid of the "create" type method?
        How can I get rid of type methods altogether?
        Why can't I create an object that replaces an old object with the same name?
        How can I make my simple type run faster?
    MACROS
        What is a macro?
        What are macros good for?
        How do I do conditional compilation?
        How do I define new type definition syntax?
        Are there are restrictions on macro names?
    KEYWORDS
    COPYRIGHT

DESCRIPTION

OVERVIEW

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 snit man page.

What is Snit?

Snit is a framework for defining abstract data types and megawidgets in pure Tcl. The name "Snit" original stood 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.

The primary purpose of Snit is to be 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.

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.

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 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.

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.

What version of Tcl does Snit require?

Snit requires version Tcl 8.4 or later.

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, http://www.wjduquette.com/snit.

What are Snit's goals?

  • A Snit object should should be at least as efficient as a hand-coded Tcl object (see http://www.wjduquette.com/tcl/objects.html).

  • The fact that Snit was used in an object's implementation should be transparent (and irrelevant) to clients of that object.

  • Snit should be able to encapsulate objects from other sources, particularly Tk widgets.

  • Snit megawidgets should be (to the extent possible) indistinguishable in interface from Tk widgets.

  • Snit should be Tclish--that is, rather than trying to emulate C++, Smalltalk, or anything else, it should try to emulate Tcl itself.

  • It should have a simple, easy-to-use, easy-to-remember syntax.

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.

Note that you can achieve the effect of inheritance using COMPONENTS and DELEGATION--and you can inherit from anything that looks like a Tcl object.

What can I do with Snit?

Using Snit, a programmer can:

  • Create abstract data types and Tk megawidgets.

  • Define instance variables, type variables, and Tk-style options.

  • Define constructors, destructors, instance methods, type methods, procs.

  • Assemble a type out of component types. Instance methods and options can be delegated to the component types automatically.

OBJECTS

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.

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 configure and cget methods. Snit uses the same conventions as Tk widgets do.

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 include some form of inheritance the word class is usually used instead of 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 object-based programming as opposed to object-oriented programming. Note that you can easily create the effect of inheritance using COMPONENTS and DELEGATION.

In Snit, as in Tk, a type is a command that creates instances -- objects -- which belong to the type. Most types define some number of options which can be set at creation time, and usually can be changed later.

Further, an 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 insert subcommand:

 
    # Create a text widget and insert some text in it.
    text .mytext -width 80 -height 24
    .mytext insert end "Howdy!"

In this example, text is the type command and .mytext is the instance command.

In Snit, object subcommands are generally called INSTANCE METHODS.

What kinds of abstract data types does Snit provide?

Snit allows you to define three kinds of abstract data types:

  • snit::type
  • snit::widget
  • snit::widgetadaptor

What is a snit::type?

A snit::type is a non-GUI abstract data type, e.g., a stack or a queue. snit::types are defined using the snit::type command. For example, if you were designing a kennel management system for a dog breeder, you'd need a dog type.

 
% snit::type dog {
    # ...
}
::dog
%

This definition defines a new command (::dog, in this case) that can be used to define dog objects.

An instance of a snit::type can have INSTANCE METHODS, INSTANCE VARIABLES, OPTIONS, and COMPONENTS. The type itself can have TYPE METHODS, TYPE VARIABLES, TYPE COMPONENTS, and PROCS.

What is a snit::widget?

A snit::widget is a Tk megawidget built using Snit; it is very similar to a snit::type. See WIDGETS.

What is a snit::widgetadaptor?

A 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 snit::widget. See WIDGET ADAPTORS.

How do I create an instance of a snit::type?

You create an instance of a snit::type by passing the new instance's name to the type's create method. In the following example, we create a dog object called spot.

 
% snit::type dog {
    # ....
}
::dog
% dog create spot
::spot
%

In general, the create method name can be omitted so long as the instance name doesn't conflict with any defined TYPE METHODS. (See TYPE COMPONENTS for the special case in which this doesn't work.) So the following example is identical to the previous example:

 
% snit::type dog {
    # ....
}
::dog
% dog spot
::spot
%

This document generally uses the shorter form.

If the dog type defines OPTIONS, these can usually be given defaults at creation time:

 
% 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
%

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:

 
% spot bark
::spot barks.
%

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,

 
% snit::type dog { ... }
::dog
% set d [dog spot -breed dalmation -color spotted]
::spot
% $d cget -breed
dalmation
% $d bark
::spot barks.
%

If you prefer this style, you might prefer to have Snit generate the instance's name automatically.

How can I generate the object name automatically?

If you'd like Snit to generate an object name for you, use the %AUTO% keyword as the requested name:

 
% snit::type dog { ... }
::dog
% set d [dog %AUTO%]
::dog2
% $d bark
::dog2 barks.
%

The "%AUTO%" keyword can be embedded in a longer string:

 
% set d [dog obj_%AUTO%]
::obj_dog4
% $d bark
::obj_dog4 barks.
%

Can types be renamed?

Tcl's 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.

snit::type commands, however, should never be renamed; to do so breaks the connection between the type and its objects.

Can objects be renamed?

Tcl's 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.

All Snit objects (including widgets and widgetadaptors) can be renamed, though this flexibility has some consequences:

  • In an instance method, the implicit argument self will always contain the object's current name, so instance methods can always call other instance methods using $self.

  • If the object is renamed, however, 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 command to another object like this:

     
    .btn configure -command [list $self ButtonPress]

    You'll get an error if .btn calls your command after your object is renamed.

  • Instead, the your object should define its callback command like this:

     
    .btn configure -command [mymethod ButtonPress]

    The 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.

  • Every object has a private namespace; the name of this namespace is available in method bodies, etc., as the value of the implicit argument selfns. This value is constant for the life of 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 available in method bodies as the value of the implicit argument 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.

How do I destroy a Snit object?

Every instance of a snit::type has a destroy method:

 
% snit::type dog { ... }
::dog
% dog spot
::spot
% spot bark
::spot barks.
% spot destroy
% spot barks
invalid command name "spot"
%

Snit megawidgets (i.e., instances of snit::widget and snit::widgetadaptor) are destroyed like any other widget: by using the Tk destroy command on the widget or on one of its ancestors in the window hierarchy.

In addition, any Snit object of any type can be destroyed by renaming it to the empty string using the Tcl rename command.

Finally, every Snit type has a type method called destroy; calling it destroys the type and all of its instances:

 
% 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"
%

INSTANCE METHODS

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.

How do I define an instance method?

Instance methods are defined in the type definition using the method statement. Consider the following code that might be used to add dogs to a computer simulation:

 
% snit::type dog {
    method bark {} {
        return "$self barks."
    }

    method chase {thing} {
        return "$self chases $thing."
    }
}
::dog
%

A dog can bark, and it can chase things.

The method statement looks just like a normal Tcl proc, except that it appears in a snit::type definition. Notice that every instance method gets an implicit argument called self; this argument contains the object's name. (There's more on implicit method arguments below.)

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:

 
% dog spot
::spot
% spot bark
::spot barks.
% spot chase cat
::spot chases cat.
%

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 self.

Suppose, for example, that our dogs never chase anything without barking at them:

 
% 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.
%

Are there any limitations on instance method names?

Not really, so long as you avoid the standard instance method names: configure, configurelist, cget, destroy, and info.

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.

Snit doesn't implement any access control on instance methods, so all methods are 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.

For example, suppose our simulated dogs only bark in response to other stimuli; they never bark just for fun. So the bark method becomes Bark to indicate that it is private:

 
% 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.
%

Are there any limitations on instance 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 args argument.

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.

What implicit arguments are passed to each instance method?

The arguments implicitly passed to every method are type, selfns, win, and self.

What is $type?

The implicit argument type contains the fully qualified name of the object's type:

 
% snit::type thing {
    method mytype {} {
        return $type
    }
}
::thing
% thing something
::something
% something mytype
::thing
%

What is $self?

The implicit argument self contains the object's fully qualified name.

If the object's command is renamed, then $self will change to match in subsequent calls. Thus, your code should not assume that $self is constant unless you know for sure that the object will never be renamed.

 
% snit::type thing {
    method myself {} {
        return $self
    }
}
::thing
% thing mutt
::mutt
% mutt myself
::mutt
% rename mutt jeff
% jeff myself
::jeff
%

What is $selfns?

Each Snit object has a private namespace in which to store its INSTANCE VARIABLES and OPTIONS. The implicit argument 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:

 
% snit::type thing {
    method myNameSpace {} {
        return $selfns
    }
}
::thing
% thing jeff
::jeff
% jeff myNameSpace
::thing::Snit_inst3
% rename jeff mutt
% mutt myNameSpace
::thing::Snit_inst3
%

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.

What is $win?

The implicit argument win is defined for all Snit methods, though it really makes sense only for those of WIDGETS and WIDGET ADAPTORS. $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.

When a 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.

Thus, using win whenever the Tk window name is called for means that a snit::widget or snit::widgetadaptor can be adapted by a snit::widgetadaptor. See WIDGETS for more information.

How do I pass an instance method as a callback?

It depends on the context.

Suppose in my application I have a dog object named fido, and I want fido to bark when a Tk button called .bark is pressed. In this case, I create the callback command in the usual way, using list:

 
    button .bark -text "Bark!" -command [list fido bark]

In typical Tcl style, we use a callback to hook two independent components together. But suppose that the dog object has a graphical interface and owns the button itself? In this case, the dog must pass one of its own instance methods to the button it owns. The obvious thing to do is this:

 
% snit::widget dog {
    constructor {args} {
        #...
        button $win.barkbtn -text "Bark!" -command [list $self bark]
        #...
    }
}
::dog
%

(Note that in this example, our dog becomes a snit::widget, because it has GUI behavior. See WIDGETS for more.) Thus, if we create a dog called .spot, it will create a Tk button called .spot.barkbtn; when pressed, the button will call $self bark.

Now, this will work--provided that .spot is never renamed to something else. But surely renaming widgets is abnormal? And so it is--unless .spot is the hull component of a snit::widgetadaptor. If it is, then it will be renamed, and .spot will become the name of the snit::widgetadaptor object. When the button is pressed, the command $self bark will be handled by the snit::widgetadaptor, which might or might not do the right thing.

There's a safer way to do it, and it looks like this:

 
% snit::widget dog {
    constructor {args} {
        #...
        button $win.barkbtn -text "Bark!" -command [mymethod bark]
        #...
    }
}
::dog
%

The command mymethod takes any number of arguments, and can be used like list to build up a callback command; the only difference is that mymethod returns a form of the command that won't change even if the instance's name changes.

How do I delegate instance methods to a component?

See DELEGATION.

INSTANCE VARIABLES

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.

How is a scalar instance variable defined?

Scalar instance variables are defined in the type definition using the variable statement. You can simply name it, or you can initialize it with a value:

 
snit::type mytype {
    # Define variable "greeting" and initialize it with "Howdy!"
    variable greeting "Howdy!"
}

How is an array instance variable defined?

Array instance variables are also defined in the type definition using the variable command. You can initialize them at the same time by specifying the -array option:

 
snit::type mytype {
    # Define array variable "greetings"
    variable greetings -array {
        formal "Good Evening"
        casual "Howdy!"
    }
}

Are there any limitations on instance variable names?

Just a few.

First, every Snit object has a built-in instance variable called options, which should never be redefined.

Second, all names beginning with "Snit_" are reserved for use by Snit internal code.

Third, instance variable names containing the namespace delimiter (::) are likely to cause great confusion.

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.

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 -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.

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 myvar command:

 
snit::widget mywidget {
    variable labeltext ""

    constructor {args} {
        # ...

        label $win.label -textvariable [myvar labeltext]

        # ...
    }
}

How do I make an instance variable public?

Practically speaking, you don't. Instead, you'll implement public variables as OPTIONS. Alternatively, you can write INSTANCE METHODS to set and get the variable's value.

OPTIONS

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.

Snit's implementation of options follows the Tk model fairly exactly, except that snit::type objects usually don't interact with THE TK OPTION DATABASE; snit::widget and snit::widgetadaptor objects, on the other hand, always do.

How do I define an option?

Options are defined in the type definition using the option statement. Consider the following type, to be used in an application that manages a list of dogs for a pet store:

 
snit::type dog {
    option -breed -default mongrel
    option -color -default brown
    option -akc   -default 0
    option -shots -default 0
}

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.

There are a number of options you can specify when defining an option; if -default is the only one, you can omit the word -default as follows:

 
snit::type dog {
    option -breed mongrel
    option -color brown
    option -akc   0
    option -shots 0
}

If no -default value is specified, the option's default value will be the empty string (but see THE TK OPTION DATABASE).

The Snit man page refers to options like these as "locally defined" options.

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 ::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.

 
% dog spot -breed beagle -color "mottled" -akc 1 -shots 1
::spot
% dog fido -shots 1
::fido
%

So ::spot is a pedigreed beagle; ::fido is a typical mutt, but his owners evidently take care of him, because he's had his shots.

Note: If the type defines a constructor, it can specify a different object-creation syntax. See CONSTRUCTORS for more information.

How can a client retrieve an option's value?

Retrieve option values using the cget method:

 
% spot cget -color
mottled
% fido cget -breed
mongrel
%

How can a client set options after object creation?

Any number of options may be set at one time using the 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:

 
% fido configure -color dun -breed "Arctic Boar Hound"
% fido cget -color
dun
% fido cget -breed
Arctic Boar Hound

Alternatively, the configurelist method takes a list of options and values; occasionally this is more convenient:

 
% 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
%

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 configure and cget methods, as shown below.

 
% 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
%

Alternatively, Snit provides a built-in array instance variable called options. The indices are the option names; the values are the option values. The method gainWeight can thus be rewritten as follows:

 
    method gainWeight {
        incr options(-weight)
    }

As you can see, using the options variable involves considerably less typing and is the usual way to do it. But if you use -configuremethod or -cgetmethod (described in the following answers), you might wish to use the configure and cget methods anyway, just so that any special processing you've implemented is sure to get done.

How can I make an option read-only?

Define the option with -readonly yes.

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.

 
% 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
%

How can I catch accesses to an option's value?

Define a -cgetmethod for the option.

What is a -cgetmethod?

A -cgetmethod is a method that's called whenever the related option's value is queried via the 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.

Here's what the default behavior would look like if written using a -cgetmethod:

 
snit::type dog {
    option -color -default brown -cgetmethod GetOption

    method GetOption {option} {
        return $options($option)
    }
}

Any instance method can be used, provided that it takes one argument, the name of the option whose value is to be retrieved.

How can I catch changes to an option's value?

Define a -configuremethod for the option.

What is a -configuremethod?

A -configuremethod is a method that's called whenever the related option is given a new value via the configure or 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.

Here's what the default configuration behavior would look like if written using a -configuremethod:

 
snit::type dog {
    option -color -default brown -configuremethod SetOption

    method SetOption {option value} {
        set options($option) $value
    }
}

Any instance method can be used, provided that it takes two arguments, the name of the option and the new value.

Note that if your method doesn't store the value in the options array, the options array won't get updated.

How can I validate an option's value?

Define a -validatemethod.

What is a -validatemethod?

A -validatemethod is a method that's called whenever the related option is given a new value via the configure or 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 -validatemethod, if any, is called before the value is stored in the options array; in particular, it's called before the -configuremethod, if any.

For example, suppose an option always takes a Boolean value. You can ensure that the value is in fact a valid Boolean like this:

 
% 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 -validatemethod can be used to validate any number of boolean options.

Any method can be a -validatemethod provided that it takes two arguments, the option name and the new option value.

TYPE VARIABLES

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 static member variable is used for the same notion. Type variables can be scalars or arrays.

How is a scalar type variable defined?

Scalar type variables are defined in the type definition using the typevariable statement. You can simply name it, or you can initialize it with a value:

 
snit::type mytype {
    # Define variable "greeting" and initialize it with "Howdy!"
    typevariable greeting "Howdy!"
}

Every object of type mytype now has access to a single variable called greeting.

How is an array-valued type variable defined?

Array-valued type variables are also defined using the typevariable command; to initialize them, include the -array option:

 
snit::type mytype {
    # Define typearray variable "greetings"
    typevariable greetings -array {
        formal "Good Evening"
        casual "Howdy!"
    }
}

Are there any limitations on type variable names?

Type variable names have the same restrictions as the names of INSTANCE VARIABLES do.

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 INSTANCE METHODS or TYPE METHODS without declaration. This differs from normal Tcl practice, in which all non-local variables in a proc need to be declared.

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 -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.

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 mytypevar command:

 
snit::widget mywidget {
    typevariable labeltext ""

    constructor {args} {
        # ...

        label $win.label -textvariable [mytypevar labeltext]

        # ...
    }
}

How do I make a type variable public?

There are two ways to do this. The preferred way is to write a pair of TYPE METHODS to set and query the type variable's value.

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,

 
snit::type mytype {
    typevariable myvariable
}

set ::mytype::myvariable "New Value"

TYPE METHODS

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.

How do I define a type method?

Type methods are defined in the type definition using the typemethod statement:

 
snit::type dog {
    # List of pedigreed dogs
    typevariable pedigreed

    typemethod pedigreedDogs {} {
        return $pedigreed
    }
}

Suppose the dog type maintains a list of the names of the dogs that have pedigrees. The pedigreedDogs type method returns this list.

The typemethod statement looks just like a normal Tcl proc, except that it appears in a snit::type definition. Notice that every type method gets an implicit argument called type, which contains the fully-qualified type name.

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 pedigreedDogs,

 
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] { ... }

Are there any limitations on type method names?

Not really, so long as you avoid the standard type method names:

create, destroy, and info.

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.

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.

Alternatively, a Snit proc can be used as a private type method; see PROCS.

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 args argument.

However, every type method is called with an implicit argument called 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 INSTANCE METHODS.

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 $type to do so:

 
snit::type dog {

    typemethod pedigreedDogs {} { ... }

    typemethod printPedigrees {} {
        foreach obj [$type pedigreedDogs] { ... }
    }
}

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, type. For example, suppose we want to print a list of pedigreed dogs when a Tk button is pushed:

 
button .btn -text "Pedigrees" -command [list dog printPedigrees]
pack .btn

Alternatively, from a method or type method you can use the mytypemethod command, just as you would use mymethod to define a callback command for an INSTANCE METHOD.

PROCS

What is a proc?

A Snit 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.

How do I define a proc?

Procs are defined by including a proc statement in the type definition:

 
snit::type mytype {
    # Pops and returns the first item from the list stored in the
    # listvar, updating the listvar
   proc pop {listvar} { ... }

   # ...
}

Are there any limitations on proc names?

Any name can be used, so long as it does not begin with Snit_; names beginning with Snit_ are reserved for Snit's own use. However, the wise programmer will avoid proc names (set, list, if, etc.) that would shadow standard Tcl command names.

proc names, being private, should begin with a capital letter according to convention; however, as there are typically no public procs in the type's namespace it doesn't matter much either way.

How does a method call a proc?

Just like it calls any Tcl command. For 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]
    }
}

How can I pass a proc to another object as a callback?

The myproc command returns a callback command for the proc, just as mymethod does for a method.

TYPE CONSTRUCTORS

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.

A type can have at most one type constructor.

How do I define a type constructor?

A type constructor is defined by using the 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.

 
% snit::type mytype {
    typevariable lookupTable

    typeconstructor {
        array set lookupTable {key value...}
    }
}

CONSTRUCTORS

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 snit::type command's 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.

The constructor's return value is ignored (unless it's an error, of course).

How do I define a constructor?

A constructor is defined by using the 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.

 
% 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
%

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:

 
snit::type dog {
    constructor {args} {
        $self configurelist $args
    }
}

When the constructor is called, 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 configurelist method, as shown.

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:

 
% 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

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 COMPONENTS using the standard creation syntax.

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 args argument.

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 snit::widgets and snit::widgetadaptors. See DELEGATION, WIDGETS, WIDGET ADAPTORS, and THE TK OPTION DATABASE.

DESTRUCTORS

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 COMPONENTS, closing files, and so forth.

How do I define a destructor?

Destructors are defined by using the destructor statement in the type definition.

Suppose we're maintaining a list of pedigreed dogs; then we'll want to remove dogs from it when they are destroyed.

 
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
    }
}

Are there any limitations on destructor arguments?

Yes; a destructor has no explicit arguments.

What implicit arguments are passed to the destructor?

The destructor gets the same implicit arguments that are passed to INSTANCE METHODS: type, selfns, win, and self.

Must components be destroyed explicitly?

Yes and no.

Any Tk widgets created by a snit::widget or 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).

Components of normal 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.

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.

For example, a dog might create a 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 tail to destroy. The simplest solution is generally to catch and ignore any errors while destroying components.

 
snit::type dog {
    component tail

    constructor {args} {
        $self configurelist $args

        set tail [tail %AUTO%]
    }

    destructor {
        catch {$tail destroy}
    }
}

COMPONENTS

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.

But Snit also has a more precise meaning for COMPONENT. The components of a Snit object are those objects to which methods or options can be delegated. (See DELEGATION for more information about delegation.)

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 component statement. The component statement declares an instance variable which is used to store the component's command name when the component is created.

For example, suppose your dog object creates a tail object (the better to wag with, no doubt):

 
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
    }
}

As shown here, it doesn't matter what the tail object's real name is; the dog object refers to it by its component name.

The above example shows one way to delegate the wag method to the mytail component; see DELEGATION for an easier way.

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.

In the example in the previous question, the component name is mytail; the mytail component's object name is chosen automatically by Snit since %AUTO% was used when the component object was created.

Are there any limitations on component names?

Yes. snit::widget and snit::widgetadaptor have a special component called the hull component; thus, the name hull should be used for no other purpose.

Otherwise, since component names are in fact instance variable names they must follow the rules for INSTANCE VARIABLES.

What is an owned component?

An owned component is a component whose object command's lifetime is controlled by the snit::type or snit::widget.

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:

 
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.

What does the install command do?

The install command creates an owned component using a specified command, and assigns the result to the component's instance variable. For 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 snit::type's code, the install command shown above is equivalent to the set mytail command that's commented out. In a snit::widget's or snit::widgetadaptor's, code, however, the install command also queries 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 install for all owned components.

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.

Are there any limitations on component object names?

Yes.

Component objects which are Tk widgets or megawidgets must have valid Tk window names.

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.

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:

 
snit::type tail { ... }

snit::type dog {
    delegate method wag to mytail

    constructor {} {
        install mytail using tail mytail
    }
}

This code uses the component name, 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 mytail component is created in the ::dog:: namespace, and will thus have the name ::dog::mytail.

Now, suppose you create two dogs. Both dogs will attempt to create a tail called ::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:

First, if the component type is a snit::type you can specify %AUTO% as its name, and be guaranteed to get a unique name. This is the safest thing to do:

 
    install mytail using tail %AUTO%

If the component type isn't a snit::type you can base the component's object name on the type's name in some way:

 
     install mytail using tail $self.mytail

This isn't as safe, but should usually work out okay.

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 snit::widget or snit::widgetadaptor you don't need to destroy any components that are widgets, because they will generally be children or descendants of your megawidget.

If your object is an instance of snit::type, though, none of its owned components will be destroyed automatically, nor will be non-widget components of a snit::widget be destroyed automatically. All such owned components must be destroyed explicitly, or they won't be destroyed at all.

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 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.

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.

How do I expose a component's object command?

When you declare the component, specify the component statement's -public option. The value of this option is the name of a method which will be delegated to your component's object command.

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:

 
snit::widget combobox {
     expose listbox -public listbox

     constructor {args} {
         install listbox using listbox $win.listbox ....
     }
}

combobox .mycombo
.mycombo listbox configure -width 30

Your comobox widget, .mycombo, now has a 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.

Usually you'll let the method name be the same as the component name; however, you can name it anything you like.

TYPE COMPONENTS

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 INSTANCE VARIABLES and TYPE VARIABLES. Both INSTANCE METHODS and TYPE METHODS can be delegated to type components.

Once you understand COMPONENTS and DELEGATION, type components are just more of the same.

How do I declare a type component?

Declare a type component using the typecomponent statement. It takes the same options (-inherit and -public) as the component statement does, and defines a type variable to hold the type component's object command.

Suppose in your model you've got many dogs, but only one veterinarian. You might make the veterinarian a type component.

 
snit::type veterinarian { ... }

snit::type dog {
    typecomponent vet

    # ...
}

How do I install a type component?

Just use the set command to assign the component's object command to the type component. Because types (even snit::widget types) are not widgets, and do not have options anyway, the extra features of the install command are not needed.

You'll usually install type components in the type constructor, as shown here:

 
snit::type veterinarian { ... }

snit::type dog {
    typecomponent vet

    typeconstructor {
        set vet [veterinarian %AUTO%]
    }
}

Are there any limitations on type component names?

Yes, the same as on INSTANCE VARIABLES, TYPE VARIABLES, and normal COMPONENTS.

DELEGATION

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 dog object can delegate its wag method and its -taillength option to its tail component.

 
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
    }

}

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.

Note that the constructor calls the configurelist method after it creates its tail; otherwise, if -taillength appeared in the list of args we'd get an error.

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 delegate statement in the type definition. (See COMPONENTS and TYPE COMPONENTS for more information about component names.)

For example, here's a much better way to delegate the dog object's wag method:

 
% snit::type dog {
    delegate method wag to mytail

    constructor {args} {
        install mytail using tail %AUTO% -partof $self
        $self configurelist $args
    }
}
::dog
% snit::type tail {
    method wag {} { return "Wag, wag, wag."}
}
::tail
% dog spot
::spot
% spot wag
Wag, wag, wag.

This code has the same effect as the code shown under the previous question: when a dog's wag method is called, the call and its arguments are passed along automatically to the tail object.

Note that when a component is mentioned in a delegate statement, the component's instance variable is defined implicitly. However, it's still good practice to declare it explicitly using the component statement.

Note also that you can define a method name using the method statement, or you can define it using delegate; you can't do both.

Can I delegate to a method with a different name?

Suppose you wanted to delegate the dog's wagtail method to the tail's wag method. After all you wag the tail, not the dog. It's easily done:

 
snit::type dog {
    delegate method wagtail to mytail as wag

    constructor {args} {
        install mytail using tail %AUTO% -partof $self
        $self configurelist $args
    }
}

Can I delegate to a method with additional arguments?

Suppose the tail's wag method takes as an argument the number of times the tail should be wagged. You want to delegate the dog's wagtail method to the tail's wag method, specifying that the tail should be wagged exactly three times. This is easily done, too:

 
snit::type dog {
    delegate method wagtail to mytail as {wag 3}
    # ...
}

snit::type tail {
    method wag {count} {
        return [string repeat "Wag " $count]
    }
    # ...
}

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 delegate statement's using clause.

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, saverec saves a record. If you let the record ID be the name of the dog object, you can delegate the dog's save method to the saverec command as follows:

 
snit::type dog {
    delegate method save using {saverec %s}
}

The %s is replaced with the instance name when the save method is called; any additional arguments are the appended to the resulting command.

The using clause understands a number of other %-conversions; in addition to the instance name, you can substitute in the method name (%m), the type name (%t), the instance namespace (%n), the Tk window name (%w), and, if a component or typecomponent name was given in the delegate statement, the component's object command (%c).

How can I delegate a method to a type component object?

Just exactly as you would to a component object. The delegate method statement accepts both component and type component names in its to clause.

How can I delegate a type method to a type component object?

Use the delegate typemethod statement. It works like delegate method, with these differences: first, it defines a type method instead of an instance method; second, the using clause ignores the %s, %n, and %w %-conversions.

Naturally, you can't delegate a type method to an instance component...Snit wouldn't know which instance should receive it.

How can I delegate an option to a component object?

The first question in this section (see 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 tail object has a -length option; we want to allow the creator of a dog object to set the tail's length. We can do this:

 
% 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

This produces nearly the same result as the -configuremethod and -cgetmethod shown under the first question in this section: whenever a dog object's -length option is set or retrieved, the underlying tail object's option is set or retrieved in turn.

Note that you can define an option name using the option statement, or you can define it using delegate; you can't do both.

Can I delegate to an option with a different name?

In the previous answer we delegated the dog's -length option down to its 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 dog a -taillength option, but delegate it to the tail's -length option:

 
snit::type dog {
    delegate option -taillength to mytail as -length

    constructor {args} {
        set mytail [tail %AUTO% -partof $self]
        $self configurelist $args
    }
}

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 snit::widgetadaptors, for example, where we wish to slightly the modify the behavior of an existing widget. To carry on with our dog example, however, suppose that we have a snit::type called animal that implements a variety of animal behaviors--moving, eating, sleeping, and so forth. We want our dog objects to inherit these same behaviors, while adding dog-like behaviors of its own. Here's how we can give a dog methods and options of its own while delegating all other methods and options to its animal component:

 
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"
    }
}

That's it. A dog is now an animal that has a -akc option and can wag its tail.

Note that we don't need to specify the full list of method names or option names that animal will receive. It gets anything dog doesn't recognize--and if it doesn't recognize it either, it will simply throw an error, just as it should.

You can also delegate all unknown type methods to a type component using delegate typemethod *.

How can I delegate all but certain methods or options to a component?

In the previous answer, we said that every dog is an animal by delegating all unknown methods and options to the animal component. But what if the animal type has some methods or options that we'd like to suppress?

One solution is to explicitly delegate all the options and methods, and forgo the convenience of delegate method * and delegate option *. But if we wish to suppress only a few options or methods, there's an easier way:

 
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
    }

    # ...
}

Dogs have four legs, so we specify that explicitly when we create the animal component, and explicitly exclude -numlegs from the set of delegated options. Similarly, dogs can neither fly nor climb, so we exclude those animal methods as shown.

WIDGETS

What is a snit::widget?

A snit::widget is the Snit version of what Tcl programmers usually call a megawidget: a widget-like object usually consisting of one or more Tk widgets all contained within a Tk frame.

A snit::widget is also a special kind of snit::type. Just about everything in this FAQ list that relates to snit::types also applies to snit::widgets.

How do I define a snit::widget?

snit::widgets are defined using the snit::widget command, just as snit::types are defined by the snit::type command.

The body of the definition can contain all of the same kinds of statements, plus a couple of others which will be mentioned below.

How do snit::widgets differ from snit::types?

  • The name of an instance of a snit::type can be any valid Tcl command name, in any namespace. The name of an instance of a snit::widget must be a valid Tk widget name, and its parent widget must already exist.

  • An instance of a snit::type can be destroyed by calling its destroy method. Instances of a snit::widget have no destroy method; use the Tk destroy command instead.

  • Every instance of a snit::widget has one predefined component called its hull component. The hull is a Tk frame or toplevel widget; any other widgets created as part of the snit::widget will usually be contained within this frame.

  • snit::widgets can have their options receive default values from THE TK OPTION DATABASE.

What is a hull component?

Snit can't create a Tk widget object; only Tk can do that. Thus, every instance of a snit::widget must be wrapped around a genuine Tk widget; this Tk widget is called the 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.

For snit::widgets the hull component must be a Tk frame or toplevel widget; any other widgets created as part of the snit::widget will be contained within this frame or toplevel.

snit::widgetadaptors differ from snit::widgets chiefly in that any kind of widget can be used as the hull component; see WIDGET ADAPTORS.

How can I set the hull type for a snit::widget?

A snit::widget's hull component will usually be a Tk frame widget; however, it may also be a toplevel widget. You can explicitly choose one or the other by including the hulltype command in the widget definition:

 
snit::widget mytoplevel {
    hulltype toplevel

    # ...
}

If no hulltype command appears, the hull will be a frame.

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 snit::widget is first created, its instance name, self, is a Tk window name; however, if the snit::widget is used as the hull component by a snit::widgetadaptor its instance name will be changed to something else. For this reason, every snit::widget method, constructor, destructor, and so forth is passed another implicit argument, win, which is the window name of the megawidget. Any children should be named using win as the root.

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:

 
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

    }
}

See also the question on renaming objects, toward the top of this file.

WIDGET ADAPTORS

What is a snit::widgetadaptor?

A snit::widgetadaptor is a kind of snit::widget. Whereas a snit::widget's hull is automatically created and is always a Tk frame, a 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.

It's called a widget adaptor because it allows you to take an existing widget and customize its behavior.

How do I define a snit::widgetadaptor?

Use the snit::widgetadaptor command. The definition for a snit::widgetadaptor looks just like that for a snit::type or snit::widget, except that the constructor must create and install the hull component.

For example, the following code creates a read-only text widget by the simple device of turning its insert and delete methods into no-ops. Then, we define new methods, ins and del, which get delegated to the hull component as insert and delete. Thus, we've adapted the text widget and given it new behavior while still leaving it fundamentally a text widget.

 
::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
}

The most important part is in the constructor. Whereas snit::widget creates the hull for you, 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 installhull command.

Note: There is no instance command until you create one by installing a hull component. Any attempt to pass methods to $self prior to calling installhull will fail.

Can I adapt a widget created elsewhere in the program?

Yes.

At times, it can be convenient to adapt a pre-existing widget instead of creating your own. For example, the Bwidget PagesManager widget manages a set of frame widgets, only one of which is visible at a time. The application chooses which frame is visible. All of the These frames are created by the PagesManager itself, using its add method. It's convenient to adapt these frames to do what we'd like them to do.

In a case like this, the Tk widget will already exist when the snit::widgetadaptor is created. Snit provides an alternate form of the installhull command for this purpose:

 
snit::widgetadaptor pageadaptor {
    constructor {args} {
        # The widget already exists; just install it.
        installhull $win

        # ...
    }
}

Can I adapt another megawidget?

Maybe. If the other megawidget is a snit::widget or 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 <Destroy> event before the megawidget you're adapting does.

THE TK OPTION DATABASE

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).

Full details about the Tk option database are beyond the scope of this document; both Practical Programming in Tcl and Tk by Welch, Jones, and Hobbs, and Effective Tcl/Tk Programming by Harrison and McClennan., have good introductions to it.

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.

  • If the widget's default widget class is not what is desired, set it explicitly using the widgetclass statement in the widget definition.

  • When defining or delegating options, specify the resource and class names explicitly when necessary.

  • Use the installhull using command to create and install the hull for snit::widgetadaptors.

  • Use the install command to create and install all components which are widgets.

  • Use the install command to create and install components which aren't widgets if you'd like them to receive option values from the option database.

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.

Do snit::types use the Tk option database?

No, they don't; querying the option database requires a Tk window name, and snit::types don't have one.

If you create an instance of a snit::type as a component of a snit::widget or snit::widgetadaptor, on the other hand, and if any options are delegated to the component, and if you use install to create and install it, then the megawidget will query the option database on the snit::type's behalf. This might or might not be what you want, so take care.

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 button widget is Button.

Similarly, the widget class of a snit::widget defaults to the unqualified type name with the first letter capitalized. For example, the widget class of

 
snit::widget ::mylibrary::scrolledText { ... }

is ScrolledText.

The widget class can also be set explicitly using the widgetclass statement within the snit::widget definition:

 
snit::widget ::mylibrary::scrolledText {
    widgetclass Text

    # ...
}

The above definition says that a scrolledText megawidget has the same widget class as an ordinary 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.

What is my snit::widgetadaptor's widget class?

The widget class of a snit::widgetadaptor is just the widget class of its hull widget; Snit has no control over this.

Note that the widget class can be changed only for frame and toplevel widgets, which is why these are the valid hull types for snit::widgets.

Try to use snit::widgetadaptors 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.

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 configure and cget commands.

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 text widget options:

 
    -background         background         Background 
    -borderwidth        borderWidth        BorderWidth 
    -insertborderwidth  insertBorderWidth  BorderWidth 
    -padx               padX               Pad

As is easily seen, sometimes the resource and class names can be inferred from the option name, but not always.

What are the resource and class names for my megawidget's options?

For options implicitly delegated to a component using delegate option *, the resource and class names will be exactly those defined by the component. The configure method returns these names, along with the option's default and current values:

 
% 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
%

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.

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":

 
% 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
%

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:

 
% snit::widget mytext {
    delegate option {-padx padX Pad} to text

    # ...
}
::mytext
% mytext .text
.text
% .text configure -padx
-padx padX Pad 1 1
%

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,

 
option add *Mywidget.texture pebbled

snit::widget mywidget {
    option -texture smooth
    # ...
}

mywidget .mywidget -texture greasy

Here, -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".

How does Snit initialize delegated options?

That depends on whether the options are delegated to the hull, or to some other component.

How does Snit initialize options delegated to the hull?

A 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:

 
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]

The question is, what are the values of variables A, B, C and D?

The value of A is "sunken". The hull is a Tk frame which has been given the widget class Mywidget; it will automatically query the option database and pick up this value. Since the -relief option is implicitly delegated to the hull, Snit takes no action.

The value of B is "red". The hull will automatically pick up the value "green" for its -background option, just as it picked up the -relief value. However, Snit knows that -hullbackground is mapped to the hull's -background option; hence, it queries the option database for -hullbackground and gets "red" and updates the hull accordingly.

The value of C is also "red", because -background is implicitly delegated to the hull; thus, retrieving it is the same as retrieving -hullbackground. Note that this case is unusual; the -background option should probably have been excluded using the delegate statement's except clause, or (more likely) delegated to some other component.

The value of D is "5", but not for the reason you think. Note that as it is defined above, the resource name for -borderwidth defaults to borderwidth, whereas the option database entry is borderWidth, in accordance with the standard Tk naming for this option. As with -relief, the hull picks up its own -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 -borderwidth option should have been delegated like this:

 
    delegate option {-borderwidth borderWidth BorderWidth} to hull

For snit::widgetadaptors, 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 snit::widgetadaptor must call installhull in its constructor. The normal way to do this is as follows:

 
snit::widgetadaptor mywidget {
    # ...
    constructor {args} {
        # ...
        installhull using text -foreground white
        # ...
    }
    # ...
}

In this case, the installhull command will create the hull using a command like this:

 
    set hull [text $win -foreground white]

The hull is a text widget, so its widget class is Text. Just as with 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.

In earlier versions of Snit, snit::widgetadaptors were expected to call installhull like this:

 
    installhull [text $win -foreground white]

This form still works--but Snit will not query the option database as described above.

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.

A component widget remains a widget still, and is therefore initialized from the option database in the usual way. A text widget remains a text widget whether it is a component of a megawidget or not, and will be created as such.

But then, the option database is queried for all options delegated to the component, and the component is initialized accordingly--provided that the install command is used to create it.

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:

 
snit::widget mywidget {
    delegate option -background to myComp

    constructor {args} {
        set myComp [text $win.text -foreground black]
    }
}

The drawback of this method is that Snit has no opportunity to initialize the component properly. Hence, the following approach is now used:

 
snit::widget mywidget {
    delegate option -background to myComp

    constructor {args} {
        install myComp using text $win.text -foreground black
    }
}

The install command does the following:

  • Builds a list of the options explicitly included in the install command--in this case, -foreground.

  • Queries the option database for all options delegated explicitly to the named component.

  • 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 -foreground) will override anything read from the option database.

  • If the widget definition implicitly delegated options to the component using delegate option *, then Snit calls the newly created component's 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 install command. For all such options, Snit queries the option database and configures the component accordingly.
You don't really need to know all of this; just use install to install your components, and Snit will try to do the right thing.

What happens if I install a non-widget as a component of widget?

A snit::type never queries the option database. However, a snit::widget can have non-widget components. And if options are delegated to those components, and if the install command is used to install those components, then they will be initialized from the option database just as widget components are.

However, when used within a megawidget, install assumes that the created component uses a reasonably standard widget-like creation syntax. If it doesn't, don't use install.

ENSEMBLE COMMANDS

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 string, file, and clock. In a sense, these are singleton objects--there's only one instance of them.

How can I create an ensemble command using Snit?

There are two ways--as a snit::type, or as an instance of a snit::type.

How can I create an ensemble command using an instance of a snit::type?

Define a type whose INSTANCE METHODS are the subcommands of your ensemble command. Then, create an instance of the type with the desired name.

For example, the following code uses DELEGATION to create a work-alike for the standard string command:

 
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-- mystring, in this case.

This method has two drawbacks. First, it leaves the type command floating about. More seriously, your shiny new ensemble command will have cget, configure, info, and destroy subcommands that you probably have no use for. But read on.

How can I create an ensemble command using a snit::type?

Define a type whose TYPE METHODS are the subcommands of your ensemble command.

For example, the following code uses DELEGATION to create a work-alike for the standard string command:

 
snit::type mystring {
    delegate typemethod * to stringhandler

    typeconstructor {
        set stringhandler string
    }
}

Now the type command itself is your ensemble command.

This method has only one drawback, and though it's major, it's also surmountable. Your new ensemble command will have create, info and destroy subcommands you don't want. And worse yet, since the create method can be implicit, users of your command will accidentally be creating instances of your 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.

The work around is to set some PRAGMAS, as shown here:

 
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 pragma statement to tell Snit that we don't want the info typemethod or the destroy typemethod, and that our type has no instances; this eliminates the create typemethod and all related code. As a result, our ensemble command will be well-behaved, with no unexpected subcommands.

PRAGMAS

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.

How do I set a pragma?

Use the pragma statement. Each pragma is an option with a value; each time you use the pragma statement you can set one or more of them.

How can I get rid of the "info" type method?

Set the -hastypeinfo pragma to no:

 
snit::type dog {
    pragma -hastypeinfo no
    # ...
}

Snit will refrain from defining the info type method.

How can I get rid of the "destroy" type method?

Set the -hastypedestroy pragma to no:

 
snit::type dog {
    pragma -hastypedestroy no
    # ...
}

Snit will refrain from defining the destroy type method.

How can I get rid of the "create" type method?

Set the -hasinstances pragma to no:

 
snit::type dog {
    pragma -hasinstances no
    # ...
}

Snit will refrain from defining the 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.

This is useful if you wish to use a snit::type to define an ensemble command rather than a type with instances.

Pragmas -hastypemethods and -hasinstances cannot both be false (or there'd be nothing left).

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 create type method directly. To get the same behavior from Snit, set the -hastypemethods pragma to no:

 
snit::type dog {
    pragma -hastypemethods no
    #...
}

# Creates ::spot
dog spot

# Tries to create an instance called ::create
dog create spot

Pragmas -hastypemethods and -hasinstances cannot both be false (or there'd be nothing left).

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 snit::type, even if the name was already in use by some other object or command. You could do the following, for 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 -canreplace pragma to yes:

 
snit::type dog {
    pragma -canreplace yes
    # ...
}

How can I make my simple type run faster?

Set the -simpledispatch pragma to yes.

Snit method dispatch is both flexible and fast, but the flexibility comes with a price. If your type doesn't require the flexibility, the -simpledispatch pragma allows you to substitute a simpler dispatch mechanism that runs quite a bit faster. The limitations are these:

  • Methods cannot be delegated.

  • uplevel and upvar do not work as expected: the caller's scope is two levels up rather than one.

  • The option-handling methods (cget, configure, and configurelist) are very slightly slower.

MACROS

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.

What are macros good for?

You can use Snit macros to define new type definition syntax, and to support conditional compilation.

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?

It's easily done. Outside of any type definition, define a macro that returns 1 if the extension is available, and 0 otherwise:

 
if {$gotFastExtension} {
    snit::macro fastcode {} {return 1}
} else {
    snit::macro fastcode {} {return 0}
}

Then, use your macro in your type definition:

 
snit::type dog {

    if {[fastcode]} {
        # Fast methods
        method bark {} {...}
        method wagtail {} {...}
    } else {
        # Slow methods
        method bark {} {...}
        method wagtail {} {...}
    }
}

How do I define new type definition syntax?

Use a macro. For example, your snit::widget's -background option should be propagated to a number of component widgets. You could implement that like this:

 
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:

 
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:

 
snit::widget mywidget {
    option -background default -white
    option -foreground default -black

    propagate -background to {comp1 comp2 comp3}
    propagate -foreground to {comp1 comp2 comp3}
}

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.

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.

If my fancy snit::widget is called ::mylib::mywidget, for example, then I should define my propagate macro as ::mylib::propagate:

 
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}
}

KEYWORDS

BWidget, C++, Incr Tcl, adaptors, class, mega widget, object, object oriented, widget, widget adaptors

COPYRIGHT

Copyright © 2003-2005, by William H. Duquette
tcltk2/inst/tklibs/snit1.0/snitfaq.man0000644000176000001440000031457212215417550017326 0ustar ripleyusers[comment {-*- tcl -*- doctools manpage}] [manpage_begin snitfaq n 1.0] [copyright {2003-2005, by William H. Duquette}] [moddesc {Snit's Not Incr Tcl, OO system}] [titledesc {Snit Frequently Asked Questions}] [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" original stood 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. [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 requires version Tcl 8.4 or later. [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 bullet] [bullet] A Snit object should should be at least as efficient as a hand-coded Tcl object (see [uri http://www.wjduquette.com/tcl/objects.html]). [bullet] The fact that Snit was used in an object's implementation should be transparent (and irrelevant) to clients of that object. [bullet] Snit should be able to encapsulate objects from other sources, particularly Tk widgets. [bullet] Snit megawidgets should be (to the extent possible) indistinguishable in interface from Tk widgets. [bullet] Snit should be Tclish--that is, rather than trying to emulate C++, Smalltalk, or anything else, it should try to emulate Tcl itself. [bullet] 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 bullet] [bullet] Create abstract data types and Tk megawidgets. [bullet] Define instance variables, type variables, and Tk-style options. [bullet] Define constructors, destructors, instance methods, type methods, procs. [bullet] Assemble a type out of component types. Instance methods and options can be delegated to the component types automatically. [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 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 types: [para] [list_begin bullet] [bullet] [cmd snit::type] [bullet] [cmd snit::widget] [bullet] [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::types] 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?}] 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?}] 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 "%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 bullet] [bullet] 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]. [bullet] 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. [bullet] Instead, the 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. [bullet] 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. [bullet] 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?}] 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] Snit megawidgets (i.e., instances of [cmd snit::widget] and [cmd snit::widgetadaptor]) are 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] In addition, any Snit object of any type can be destroyed by renaming it to the empty string using the Tcl [cmd rename] command. [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]. [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. [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 {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. [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 ::spot is a pedigreed beagle; ::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] [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. [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. [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 {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. [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: [para] [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 an [sectref {INSTANCE METHOD}]. [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 {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] 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 base the component's object name on the type's name in some way: [para] [example { install mytail using tail $self.mytail }] [para] This isn't as safe, but should usually work out okay. [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 { expose 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 {args} { install mytail using tail %AUTO% -partof $self $self configurelist $args } } ::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. [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 bullet] [bullet] 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. [bullet] 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. [bullet] Every instance of a [cmd snit::widget] has one predefined component called its [var hull] component. The hull is a Tk [cmd frame] or [cmd toplevel] widget; any other widgets created as part of the [cmd snit::widget] will usually be contained within this frame. [bullet] [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 [cmd frame] or [cmd toplevel] widget; any other widgets created as part of the [cmd snit::widget] will be contained within this frame or toplevel. [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 also be a [cmd toplevel] widget. You can explicitly choose one or the other 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]. [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 bullet] [bullet] If the widget's default widget class is not what is desired, set it explicitly using the [cmd widgetclass] statement in the widget definition. [bullet] When defining or delegating options, specify the resource and class names explicitly when necessary. [bullet] Use the [cmd {installhull using}] command to create and install the hull for [cmd snit::widgetadaptor]s. [bullet] Use the [cmd install] command to create and install all components which are widgets. [bullet] 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 bullet] [bullet] Builds a list of the options explicitly included in the [cmd install] command--in this case, [const -foreground]. [bullet] Queries the option database for all options delegated explicitly to the named component. [bullet] 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. [bullet] 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 cget], [method configure], [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?}] Set the [const -simpledispatch] pragma to [const yes]. [para] Snit 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 bullet] [bullet] Methods cannot be delegated. [bullet] [cmd uplevel] and [cmd upvar] do not work as expected: the caller's scope is two levels up rather than one. [bullet] The option-handling methods ([cmd cget], [cmd configure], and [cmd configurelist]) are very slightly slower. [list_end] [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} } }] [keywords class {object oriented} object C++] [keywords {Incr Tcl} BWidget] [keywords widget adaptors {widget adaptors} {mega widget}] [manpage_end] tcltk2/inst/tklibs/snit1.0/ChangeLog0000644000176000001440000006571212215417550016735 0ustar ripleyusers2005-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/snit1.0/snit.test0000644000176000001440000044622612215417550017044 0ustar ripleyusers# -*-Tcl-*- #--------------------------------------------------------------------- # TITLE: # snit.test # # AUTHOR: # Will Duquette # # DESCRIPTION: # Test cases for snit.tcl. Uses the ::tcltest:: harness. # Note: # Snit assumes Tcl 8.4 # The tests assume tcltest 2.1 #--------------------------------------------------------------------- # Load the tcltest package, initialize some constraints. if {![package vsatisfies [package provide Tcl] 8.4]} { puts "Aborting tests for snit." puts "Requiring Tcl 8.4, have [package present Tcl]" return } if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 namespace import ::tcltest::* } else { # Ensure that 2.1 or higher present. if {![package vsatisfies [package present tcltest] 2.1]} { puts "Aborting tests for snit." puts "Requiring tcltest 2.1, have [package present tcltest]" return } } if { [lsearch $auto_path [file dirname [info script]]] == -1 } { set auto_path [linsert $auto_path 0 [file dirname [info script]]] } set ::tcltest::testConstraints(tk) [info exists tk_version] if {$::tcltest::testConstraints(tk) && ![catch {package require BWidget} result]} { set ::tcltest::testConstraints(bwidget) 1 } else { set ::tcltest::testConstraints(bwidget) 0 } #--------------------------------------------------------------------- # Load the snit package. package forget snit catch {namespace delete snit} if {[catch {source [file join [file dirname [info script]] snit.tcl]} msg]} { puts "skipped [file tail [info script]]: $msg" return } puts "- Tcl [package present Tcl]" puts "- snit [package present 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 {[info commands "spot"] ne ""} { puts "spot not erased!" error "spot not erased!" } if {[info commands "fido"] ne ""} { puts "fido not erased!" error "fido not erased!" } } #----------------------------------------------------------------------- # 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%" } -result {Prefix: My %TEMPLATE%} -cleanup { unset text } test Mappend-1.2 {template, no matching arguments} -body { set text "Prefix: " snit::Mappend text "My %TEMPLATE%" %FOO% foo } -result {Prefix: My %TEMPLATE%} -cleanup { unset text } test Mappend-1.3 {template with matching arguments} -body { set text "Prefix: " snit::Mappend text "%FOO% %BAR% %FOO%" %FOO% bar %BAR% foo } -result {Prefix: bar foo bar} -cleanup { unset text } test Mappend-1.4 {template with odd number of arguments} -body { set text "Prefix: " snit::Mappend text "%FOO% %BAR% %FOO%" %FOO% } -result {char map list unbalanced} -returnCodes error -cleanup { unset text } 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% } -result {::mytype3} -cleanup { unset counter rename ::mytype1 "" rename ::mytype2 "" } test RT.UniqueName-1.3 {nested type name} -body { set counter 0 snit::RT.UniqueName counter ::thisis::yourtype ::your::%AUTO% } -result {::your::yourtype1} -cleanup { unset counter } test RT.UniqueInstanceNamespace-1.1 {no name collision} -setup { namespace eval ::mytype:: {} } -body { set counter 0 snit::RT.UniqueInstanceNamespace counter ::mytype } -result {::mytype::Snit_inst1} -cleanup { unset counter namespace delete ::mytype:: } 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 } -result {::mytype::Snit_inst3} -cleanup { unset counter namespace delete ::mytype:: } test Contains-1.1 {contains element} -setup { set mylist {foo bar baz} } -body { snit::Contains baz $mylist } -result {1} -cleanup { unset mylist } test Contains-1.2 {does not contain element} -setup { set mylist {foo bar baz} } -body { snit::Contains quux $mylist } -result {0} -cleanup { unset mylist } #----------------------------------------------------------------------- # 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} {} { set compResult [compile type dog { }] list [llength $compResult] [lindex $compResult 0] } {2 ::dog} #----------------------------------------------------------------------- # type destruction test typedestruction-1.1 {type command is deleted} {} { type dog { } dog destroy info command ::dog } {} test typedestruction-1.2 {instance commands are deleted} {} { type dog { } dog create spot dog destroy info command ::spot } {} test typedestruction-1.3 {type namespace is deleted} {} { type dog { } dog destroy namespace exists ::dog } {0} test typedestruction-1.4 {type proc is destroyed on error} {} { catch {type dog { error "Error creating dog" }} result list [namespace exists ::dog] [info command ::dog] } {0 {}} #----------------------------------------------------------------------- # type and typemethods test type-1.1 {type names get qualified} {} { cleanup type dog {} } {::dog} test type-1.2 {typemethods can be defined} {} { cleanup type dog { typemethod foo {a b} { return [list $a $b] } } dog foo 1 2 } {1 2} test type-1.3 {upvar works in typemethods} {} { cleanup type dog { typemethod goodname {varname} { upvar $varname myvar set myvar spot } } set thename fido dog goodname thename set thename } {spot} test type-1.4 {typemethod args can't include type} {} { cleanup catch { type dog { typemethod foo {a type b} { } } } result set result } {typemethod foo's arglist may not contain "type" explicitly} test type-1.5 {typemethod args can't include self} {} { cleanup catch { type dog { typemethod foo {a self b} { } } } result set result } {typemethod foo's arglist may not contain "self" explicitly} test type-1.6 {typemethod args can span multiple lines} {} { cleanup # 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 } { } } } {::dog} #----------------------------------------------------------------------- # typeconstructor test typeconstructor-1.1 {a typeconstructor can be defined} {} { cleanup type dog { typevariable a typeconstructor { set a 1 } typemethod aget {} { return $a } } dog aget } {1} test typeconstructor-1.2 {only one typeconstructor can be defined} {} { cleanup catch { type dog { typevariable a typeconstructor { set a 1 } typeconstructor { set a 2 } } } result set result } {too many typeconstructors} test typeconstructor-1.3 {type proc is destroyed on error} {} { catch { type dog { typeconstructor { error "Error creating dog" } } } result list [namespace exists ::dog] [info command ::dog] } {0 {}} #----------------------------------------------------------------------- # Type components test typecomponent-1.1 {typecomponent defines typevariable} {} { cleanup catch { type dog { typecomponent mycomp typemethod test {} { return $mycomp } } dog test } result set result } {} test typecomponent-1.2 {typecomponent trace executes} {} { cleanup type dog { typecomponent mycomp typemethod test {} { typevariable Snit_typecomponents set mycomp foo return $Snit_typecomponents(mycomp) } } dog test } {foo} test typecomponent-1.3 {typecomponent -public works} {} { cleanup type dog { typecomponent mycomp -public string typeconstructor { set mycomp string } } dog string length foo } {3} test typecomponent-1.4 {typecomponent -inherit yes} {} { cleanup type dog { typecomponent mycomp -inherit yes typeconstructor { set mycomp string } } dog length foo } {3} #----------------------------------------------------------------------- # hierarchical type methods test htypemethod1.1 {hierarchical method, two tokens} {} { cleanup type dog { typemethod {wag tail} {} { return "wags tail" } } dog wag tail } {wags tail} test htypemethod1.2 {hierarchical method, three tokens} {} { cleanup type dog { typemethod {wag tail proudly} {} { return "wags tail proudly" } } dog wag tail proudly } {wags tail proudly} test htypemethod1.3 {hierarchical method, three tokens} {} { cleanup type dog { typemethod {wag tail really high} {} { return "wags tail really high" } } dog wag tail really high } {wags tail really high} test htypemethod1.4 {redefinition is OK} {} { cleanup type dog { typemethod {wag tail} {} { return "wags tail" } typemethod {wag tail} {} { return "wags tail briskly" } } dog wag tail } {wags tail briskly} test htypemethod1.5 {proper error on missing submethod} {} { cleanup type dog { typemethod {wag tail} {} { } } catch {dog wag} result set result } {wrong number args: should be "::dog wag method args"} test htypemethod2.1 {prefix/method collision} {} { cleanup catch { type dog { typemethod wag {} {} typemethod {wag tail} {} {} } } result set result } {Error in "typemethod {wag tail}...", "wag" has no submethods.} test htypemethod2.2 {prefix/method collision} {} { cleanup catch { type dog { typemethod {wag tail} {} {} typemethod wag {} {} } } result set result } {Error in "typemethod wag...", "wag" has submethods.} test htypemethod2.3 {prefix/method collision} {} { cleanup catch { type dog { typemethod {wag tail} {} {} typemethod {wag tail proudly} {} {} } } result set result } {Error in "typemethod {wag tail proudly}...", "wag tail" has no submethods.} test htypemethod2.4 {prefix/method collision} {} { cleanup catch { type dog { typemethod {wag tail proudly} {} {} typemethod {wag tail} {} {} } } result set result } {Error in "typemethod {wag tail}...", "wag tail" has submethods.} #----------------------------------------------------------------------- # Typemethod delegation test dtypemethod-1.1 {delegate typemethod to non-existent component} {} { cleanup set result "" type dog { delegate typemethod foo to bar } catch {dog foo} result set result } {::dog delegates typemethod "foo" to undefined typecomponent "bar"} test dtypemethod-1.2 {delegating to existing typecomponent} { cleanup type dog { delegate typemethod length to string typeconstructor { set string string } } dog length foo } {3} test dtypemethod-1.3 {delegating to existing typecomponent with error} { cleanup type dog { delegate typemethod length to string typeconstructor { set string string } } set result "" catch {dog length foo bar} result set result } {wrong # args: should be "string length string"} test dtypemethod-1.4 {delegating unknown typemethods to existing typecomponent} { cleanup type dog { delegate typemethod * to string typeconstructor { set string string } } dog length foo } {3} test dtypemethod-1.5 {delegating unknown typemethod to existing typecomponent with error} { cleanup type dog { delegate typemethod * to stringhandler typeconstructor { set stringhandler string } } set result "" catch {dog foo bar} result set result } {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} test dtypemethod-1.6 {can't delegate local typemethod: order 1} { cleanup catch { type dog { typemethod foo {} {} delegate typemethod foo to bar } } result set result } {Error in "delegate typemethod foo...", "foo" has been defined locally.} test dtypemethod-1.7 {can't delegate local typemethod: order 2} { cleanup catch { type dog { delegate typemethod foo to bar typemethod foo {} {} } } result set result } {Error in "typemethod foo...", "foo" has been delegated} test dtypemethod-1.8 {excepted methods are caught properly} { cleanup 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 } {3 {"::dog match" is not defined} {"::dog index" is not defined}} test dtypemethod-1.9 {as clause can include arguments} { cleanup proc tail {a b} { return "<$a $b>" } type dog { delegate typemethod wag to tail as {wag briskly} typeconstructor { set tail tail } } dog wag } {} test dtypemethod-2.1 {'using "%c %m"' gets normal behavior} { cleanup type dog { delegate typemethod length to string using {%c %m} typeconstructor { set string string } } dog length foo } {3} test dtypemethod-2.2 {All relevant 'using' conversions are converted} { cleanup proc echo {args} { return $args } type dog { delegate typemethod {tail wag} using {echo %% %t %M %m %j %n %w %s %c} } dog tail wag } {% ::dog {tail wag} wag tail_wag %n %w %s %c} test dtypemethod-2.3 {"%%" is handled properly} { cleanup proc echo {args} { join $args "|" } type dog { delegate typemethod wag using {echo %%m %%%m} } dog wag } {%m|%wag} test dtypemethod-2.4 {Method "*" and "using"} { cleanup proc echo {args} { join $args "|" } type dog { delegate typemethod * using {echo %m} } list [dog wag] [dog bark loudly] } {wag bark|loudly} test dtypemethod-3.1 {typecomponent names can be changed dynamically} { cleanup 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 } {3 length|foo} test dtypemethod-4.1 {hierarchical typemethod, two tokens} {} { cleanup type tail { method wag {} {return "wags tail"} } type dog { typeconstructor { set tail [tail] } delegate typemethod {wag tail} to tail as wag } dog wag tail } {wags tail} test dtypemethod-4.2 {hierarchical typemethod, three tokens} {} { cleanup type tail { method wag {} {return "wags tail"} } type dog { typeconstructor { set tail [tail] } delegate typemethod {wag tail proudly} to tail as wag } dog wag tail proudly } {wags tail} test dtypemethod-4.3 {hierarchical typemethod, three tokens} {} { cleanup type tail { method wag {} {return "wags tail"} } type dog { typeconstructor { set tail [tail] } delegate typemethod {wag tail really high} to tail as wag } dog wag tail really high } {wags tail} test dtypemethod-4.4 {redefinition is OK} {} { cleanup type tail { method {wag tail} {} {return "wags tail"} method {wag briskly} {} {return "wags tail briskly"} } type dog { typeconstructor { set tail [tail] } delegate typemethod {wag tail} to tail as {wag tail} delegate typemethod {wag tail} to tail as {wag briskly} } dog wag tail } {wags tail briskly} test dtypemethod-4.5 {last token is used by default} {} { cleanup type tail { method wag {} {return "wags tail"} } type dog { typeconstructor { set tail [tail] } delegate typemethod {tail wag} to tail } dog tail wag } {wags tail} test dtypemethod-4.6 {last token can be *} {} { cleanup type tail { method wag {} {return "wags"} method droop {} {return "droops"} } type dog { typeconstructor { set tail [tail] } delegate typemethod {tail *} to tail } list [dog tail wag] [dog tail droop] } {wags droops} test dtypemethod-4.7 {except with multiple tokens} {} { cleanup type tail { method wag {} {return "wags"} method droop {} {return "droops"} } type dog { typeconstructor { set tail [tail] } delegate typemethod {tail *} to tail except droop } catch {dog tail droop} result list [dog tail wag] $result } {wags {"::dog tail droop" is not defined}} test dtypemethod-4.8 {"*" in the wrong spot} {} { cleanup catch { type dog { delegate typemethod {tail * wag} to tail } } result set result } {Error in "delegate typemethod {tail * wag}...", "*" must be the last token.} test dtypemethod-5.1 {prefix/typemethod collision} {} { cleanup catch { type dog { delegate typemethod wag to tail delegate typemethod {wag tail} to tail as wag } } result set result } {Error in "delegate typemethod {wag tail}...", "wag" has no submethods.} test dtypemethod-5.2 {prefix/typemethod collision} {} { cleanup catch { type dog { delegate typemethod {wag tail} to tail as wag delegate typemethod wag to tail } } result set result } {Error in "delegate typemethod wag...", "wag" has submethods.} test dtypemethod-5.3 {prefix/typemethod collision} {} { cleanup catch { type dog { delegate typemethod {wag tail} to tail delegate typemethod {wag tail proudly} to tail as wag } } result set result } {Error in "delegate typemethod {wag tail proudly}...", "wag tail" has no submethods.} test dtypemethod-5.4 {prefix/typemethod collision} {} { cleanup catch { type dog { delegate typemethod {wag tail proudly} to tail as wag delegate typemethod {wag tail} to tail } } result set result } {Error in "delegate typemethod {wag tail}...", "wag tail" has submethods.} #----------------------------------------------------------------------- # type creation test creation-1.1 {type instance names get qualified} {} { cleanup type dog { } dog create spot } {::spot} test creation-1.2 {type instance names can be generated} {} { cleanup # Note: do not use type "abc" in any other test. type abc { } abc create my%AUTO% } {::myabc1} test creation-1.3 {"create" method is optional} {} { cleanup type dog { } dog fido } {::fido} test creation-1.4 {constructor arg can't be type} {} { cleanup catch { type dog { constructor {type} { } } } result set result } {constructor's arglist may not contain "type" explicitly} test creation-1.5 {constructor arg can't be self} {} { cleanup catch { type dog { constructor {self} { } } } result set result } {constructor's arglist may not contain "self" explicitly} test creation-1.6 {weird names are OK} {} { cleanup type confused-dog { method meow {} { return "$self meows." } } confused-dog spot spot meow } {::spot meows.} test creation-1.7 {If -hasinstances yes, [$type] == [$type create %AUTO%]} { cleanup type dog { variable dummy } set mydog [dog] } {::dog1} test creation-1.8 {If -hasinstances no, [$type] != [$type create %AUTO%]} { cleanup type dog { pragma -hasinstances no } catch {set mydog [dog]} result set result } {wrong # args: should be "::dog method args"} test creation-1.9 {If widget, [$type] != [$type create %AUTO%]} tk { cleanup widget dog { variable dummy } catch {set mydog [dog]} result set result } {wrong # args: should be "::dog method args"} #----------------------------------------------------------------------- # procs test proc-1.1 {proc args can span multiple lines} {} { cleanup # 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 } { } } } {::dog} #----------------------------------------------------------------------- # methods test method-1.1 {methods get called} {} { cleanup type dog { method bark {} { return "$self barks" } } dog create spot spot bark } {::spot barks} test method-1.2 {methods can call other methods} {} { cleanup type dog { method bark {} { return "$self barks." } method chase {quarry} { return "$self chases $quarry; [$self bark]" } } dog create spot spot chase cat } {::spot chases cat; ::spot barks.} test method-1.3 {instances can call one another} {} { cleanup 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 } {::spot chases ::fido; ::fido barks. ::spot barks.} test method-1.4 {upvar works in methods} {} { cleanup type dog { method goodname {varname} { upvar $varname myvar set myvar spot } } dog create fido set thename fido fido goodname thename set thename } {spot} test method-1.5 {unknown methods get an error} {} { cleanup type dog { } dog create spot set result "" catch {spot chase} result set result } {"::spot chase" is not defined} test method-1.6 {info type method returns the object's type} {} { cleanup type dog { } dog create spot spot info type } {::dog} test method-1.7 {instance method can call type method} {} { cleanup type dog { typemethod hello {} { return "Hello" } method helloworld {} { return "[$type hello], World!" } } dog create spot spot helloworld } {Hello, World!} test method-1.8 {type methods must be qualified} {} { cleanup type dog { typemethod hello {} { return "Hello" } method helloworld {} { return "[hello], World!" } } dog create spot catch {spot helloworld} result set result } {invalid command name "hello"} test method-1.9 {too few arguments} {} { cleanup type dog { method bark {volume} { } } dog create spot set result "" catch {spot bark} result set result } {wrong # args: should be "::dog::Snit_methodbark type selfns win self volume"} test method-1.10 {too many arguments} {} { cleanup type dog { method bark {volume} { } } dog create spot set result "" catch {spot bark really loud} result set result } {wrong # args: should be "::dog::Snit_methodbark type selfns win self volume"} test method-1.11 {method args can't include type} {} { cleanup catch { type dog { method foo {a type b} { } } } result set result } {method foo's arglist may not contain "type" explicitly} test method-1.12 {method args can't include self} {} { cleanup catch { type dog { method foo {a self b} { } } } result set result } {method foo's arglist may not contain "self" explicitly} test method-1.13 {method args can span multiple lines} {} { cleanup # 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 } { } } } {::dog} #----------------------------------------------------------------------- # hierarchical methods test hmethod-1.1 {hierarchical method, two tokens} {} { cleanup type dog { method {wag tail} {} { return "$self wags tail." } } dog spot spot wag tail } {::spot wags tail.} test hmethod-1.2 {hierarchical method, three tokens} {} { cleanup type dog { method {wag tail proudly} {} { return "$self wags tail proudly." } } dog spot spot wag tail proudly } {::spot wags tail proudly.} test hmethod-1.3 {hierarchical method, three tokens} {} { cleanup type dog { method {wag tail really high} {} { return "$self wags tail really high." } } dog spot spot wag tail really high } {::spot wags tail really high.} test hmethod-1.4 {redefinition is OK} {} { cleanup type dog { method {wag tail} {} { return "$self wags tail." } method {wag tail} {} { return "$self wags tail briskly." } } dog spot spot wag tail } {::spot wags tail briskly.} test hmethod-1.5 {proper error on missing submethod} {} { cleanup type dog { method {wag tail} {} { } } dog spot catch {spot wag} result set result } {wrong number args: should be "::spot wag method args"} test hmethod-2.1 {prefix/method collision} {} { cleanup catch { type dog { method wag {} {} method {wag tail} {} { return "$self wags tail." } } } result set result } {Error in "method {wag tail}...", "wag" has no submethods.} test hmethod-2.2 {prefix/method collision} {} { cleanup catch { type dog { method {wag tail} {} { return "$self wags tail." } method wag {} {} } } result set result } {Error in "method wag...", "wag" has submethods.} test hmethod-2.3 {prefix/method collision} {} { cleanup catch { type dog { method {wag tail} {} {} method {wag tail proudly} {} { return "$self wags tail." } } } result set result } {Error in "method {wag tail proudly}...", "wag tail" has no submethods.} test hmethod-2.4 {prefix/method collision} {} { cleanup catch { type dog { method {wag tail proudly} {} { return "$self wags tail." } method {wag tail} {} {} } } result set result } {Error in "method {wag tail}...", "wag tail" has submethods.} #----------------------------------------------------------------------- # mymethod and renaming test rename-1.1 {mymethod uses name of instance name variable} {} { cleanup type dog { method mymethod {} { list [mymethod] [mymethod "A B"] [mymethod A B] } } dog fido fido mymethod } {{::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} {} { cleanup 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 } {{::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} {} { cleanup type dog { } dog fido rename fido "" namespace children ::dog } {} test rename-1.4 {rename to "" deletes an instance even after a rename} {} { cleanup type dog { } dog fido rename fido spot rename spot "" namespace children ::dog } {} test rename-1.5 {creating an object twice destroys the first instance} {} { cleanup 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 } {::dog::Snit_inst1 ::dog::Snit_inst2 {}} #----------------------------------------------------------------------- # mymethod actually works test mymethod-1.1 {run mymethod handler} { cleanup 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 } {::bar::fubar snarf} #----------------------------------------------------------------------- # myproc test myproc-1.1 {myproc qualifies proc names} {} { cleanup type dog { proc foo {} {} typemethod getit {} { return [myproc foo] } } dog getit } {::dog::foo} test myproc-1.2 {myproc adds arguments} {} { cleanup type dog { proc foo {} {} typemethod getit {} { return [myproc foo "a b"] } } dog getit } {::dog::foo {a b}} test myproc-1.3 {myproc adds arguments} {} { cleanup type dog { proc foo {} {} typemethod getit {} { return [myproc foo "a b" c d] } } dog getit } {::dog::foo {a b} c d} test myproc-1.4 {procs with selfns work} {} { cleanup type dog { variable datum foo method qualify {} { return [myproc getdatum $selfns] } proc getdatum {selfns} { return $datum } } dog create spot eval [spot qualify] } {foo} #----------------------------------------------------------------------- # mytypemethod test mytypemethod-1.1 {mytypemethod qualifies typemethods} {} { cleanup 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] } {{::dog this} {::dog this x} {::dog this {x y}} {::dog this x y}} #----------------------------------------------------------------------- # typevariable test typevariable-1.1 {typevarname qualifies typevariables} {} { # Note: typevarname is DEPRECATED. Use mytypevar instead. cleanup type dog { method tvname {name} { typevarname $name } } dog create spot spot tvname myvar } {::dog::myvar} test typevariable-1.2 {undefined typevariables are OK} {} { cleanup 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] } {Howdy Howdy Howdy} test typevariable-1.3 {predefined typevariables are OK} {} { cleanup type dog { typevariable greeting Hello method tget {} { return $greeting } } dog create spot dog create fido list [spot tget] [fido tget] [set ::dog::greeting] } {Hello Hello Hello} test typevariable-1.4 {typevariables can be arrays} {} { cleanup 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) } {Hi Howdy} test typevariable-1.5 {typevariables can used in typemethods} {} { cleanup type dog { typevariable greetings Howdy typemethod greet {} { return $greetings } } dog greet } {Howdy} test typevariable-1.6 {typevariables can used in procs} {} { cleanup type dog { typevariable greetings Howdy method greet {} { return [realGreet] } proc realGreet {} { return $greetings } } dog create spot spot greet } {Howdy} test typevariable-1.7 {mytypevar qualifies typevariables} {} { cleanup type dog { method tvname {name} { mytypevar $name } } dog create spot spot tvname myvar } {::dog::myvar} test typevariable-1.8 {typevariable with too many initializers throws an error} {} { cleanup catch { type dog { typevariable color dark brown } } result set result } {Error in "typevariable color...", too many initializers} test typevariable-1.9 {typevariable with too many initializers throws an error} {} { cleanup catch { type dog { typevariable color -array dark brown } } result set result } {Error in "typevariable color...", too many initializers} test typevariable-1.10 {typevariable can initialize array variables} {} { cleanup type dog { typevariable data -array { family jones color brown } typemethod getdata {item} { return $data($item) } } list [dog getdata family] [dog getdata color] } {jones brown} #----------------------------------------------------------------------- # instance variable test ivariable-1.1 {myvar qualifies instance variables} {} { cleanup type dog { method vname {name} { myvar $name } } dog create spot spot vname somevar } {::dog::Snit_inst1::somevar} test ivariable-1.2 {undefined instance variables are OK} {} { cleanup 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] } {Hey Howdy Hey} test ivariable-1.3 {instance variables are destroyed automatically} {} { cleanup 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] } {Hi 0} test ivariable-1.4 {defined instance variables need not be declared} {} { cleanup type dog { variable greetings method put {} { set greetings Howdy } method get {} { return $greetings } } dog create spot spot put spot get } {Howdy} test ivariable-1.5 {instance variables can be arrays} {} { cleanup 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)] } {Hi Howdy} test ivariable-1.6 {instance variables can be initialized in the definition} {} { cleanup type dog { variable greetings {Hi Howdy} variable empty {} method list {} { list $greetings $empty } } dog create spot spot list } {{Hi Howdy} {}} test ivariable-1.7 {variable is illegal when selfns is undefined} {} { cleanup type dog { method caller {} { callee } proc callee {} { variable foo } } dog create spot set result "" catch {spot caller} result set result } {can't read "selfns": no such variable} test ivariable-1.8 {myvar is illegal when selfns is undefined} {} { cleanup type dog { method caller {} { callee } proc callee {} { myvar foo } } dog create spot set result "" catch {spot caller} result set result } {can't read "selfns": no such variable} test ivariable-1.9 {procs which define selfns see instance variables} {} { cleanup type dog { variable greeting Howdy method caller {} { return [callee $selfns] } proc callee {selfns} { return $greeting } } dog create spot spot caller } {Howdy} test ivariable-1.10 {in methods, variable works with fully qualified names} {} { cleanup namespace eval ::somenamespace:: { set somevar somevalue } type dog { method get {} { variable ::somenamespace::somevar return $somevar } } dog create spot spot get } {somevalue} test ivariable-1.11 {variable with too many initializers throws an error} {} { cleanup catch { type dog { variable color dark brown } } result set result } {Error in "variable color...", too many initializers} test ivariable-1.12 {variable with too many initializers throws an error} {} { cleanup catch { type dog { variable color -array dark brown } } result set result } {Error in "variable color...", too many initializers} test ivariable-1.13 {variable can initialize array variables} {} { cleanup type dog { variable data -array { family jones color brown } method getdata {item} { return $data($item) } } dog spot list [spot getdata family] [spot getdata color] } {jones brown} #----------------------------------------------------------------------- # codename # # NOTE: codename is deprecated; myproc should be used instead. test codename-1.1 {codename qualifies procs} {} { cleanup type dog { method qualify {} { return [codename myproc] } proc myproc {} { } } dog create spot spot qualify } {::dog::myproc} test codename-1.2 {procs with selfns work} {} { cleanup type dog { variable datum foo method qualify {} { return [list [codename getdatum] $selfns] } proc getdatum {selfns} { return $datum } } dog create spot eval [spot qualify] } {foo} #----------------------------------------------------------------------- # Options test option-1.1 {options get default values} {} { cleanup type dog { option -color golden } dog create spot spot cget -color } {golden} test option-1.2 {options can be set} {} { cleanup type dog { option -color golden } dog create spot spot configure -color black spot cget -color } {black} test option-1.3 {multiple options can be set} {} { cleanup type dog { option -color golden option -akc 0 } dog create spot spot configure -color brown -akc 1 list [spot cget -color] [spot cget -akc] } {brown 1} test option-1.4 {options can be retrieved as instance variable} {} { cleanup 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 } {black 1} test option-1.5 {options can be set as an instance variable} {} { cleanup 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] } {black 1} test option-1.6 {options can be set at creation time} {} { cleanup type dog { option -color golden option -akc 0 } dog create spot -color white -akc 1 list [spot cget -color] [spot cget -akc] } {white 1} test option-1.7 {undefined option: cget} {} { cleanup type dog { option -color golden option -akc 0 } dog create spot set result {} catch {spot cget -colour} result set result } {unknown option "-colour"} test option-1.8 {undefined option: configure} {} { cleanup type dog { option -color golden option -akc 0 } dog create spot set result {} catch {spot configure -colour blue} result set result } {unknown option "-colour"} test option-1.9 {options default to ""} {} { cleanup type dog { option -color } dog create spot spot cget -color } {} test option-1.10 {spaces allowed in option defaults} {} { cleanup type dog { option -breed "golden retriever" } dog fido fido cget -breed } {golden retriever} test option-1.11 {brackets allowed in option defaults} {} { cleanup type dog { option -regexp {[a-z]+} } dog fido fido cget -regexp } {[a-z]+} test option-2.1 {configure returns info, local options only} {} { cleanup type dog { option -color black option -akc 1 } dog create spot spot configure -color red spot configure -akc 0 spot configure } {{-color color Color black red} {-akc akc Akc 1 0}} test option-2.2 {configure -opt returns info, local options only} {} { cleanup type dog { option -color black option -akc 1 } dog create spot spot configure -color red spot configure -color } {-color color Color black red} test option-2.3 {configure -opt returns info, explicit options} {} { cleanup 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 } {-akc akc Akc 1 0} test option-2.4 {configure -unknownopt} {} { cleanup 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 catch {spot configure -foo} result set result } {unknown option "-foo"} test option-2.5 {configure returns info, unknown options} tk { cleanup 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 } {{-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} tk { cleanup widgetadaptor myframe { delegate option * to hull constructor {args} { installhull [frame $self] } } myframe .frm catch {.frm configure -quux} result destroy .frm tkbide set result } {unknown option "-quux"} test option-3.1 {set option resource name explicitly} { cleanup type dog { option {-tailcolor tailColor} black } dog fido fido configure -tailcolor } {-tailcolor tailColor TailColor black black} test option-3.2 {set option class name explicitly} { cleanup type dog { option {-tailcolor tailcolor TailColor} black } dog fido fido configure -tailcolor } {-tailcolor tailcolor TailColor black black} test option-3.3 {delegated option's names come from owner} { cleanup 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 } {-tailcolor tailcolor Tailcolor black black} test option-3.4 {delegated option's resource name set explicitly} { cleanup 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 } {-tailcolor tailColor TailColor black black} test option-3.5 {delegated option's class name set explicitly} { cleanup 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 } {-tailcolor tailcolor TailColor black black} test option-3.6 {delegated option's default comes from component} { cleanup 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 } {-tailcolor tailcolor Tailcolor black red} test option-4.1 {local option name must begin with hyphen} { cleanup catch { type dog { option nohyphen } } result set result } {Error in "option nohyphen...", badly named option "nohyphen"} test option-4.2 {local option name must be lower case} { cleanup catch { type dog { option -Upper } } result set result } {Error in "option -Upper...", badly named option "-Upper"} test option-4.3 {local option name may not contain spaces} { cleanup catch { type dog { option {"-with space"} } } result set result } {Error in "option {"-with space"}...", badly named option "-with space"} test option-4.4 {delegated option name must begin with hyphen} { cleanup catch { type dog { delegate option nohyphen to tail } } result set result } {Error in "delegate option nohyphen...", badly named option "nohyphen"} test option-4.5 {delegated option name must be lower case} { cleanup catch { type dog { delegate option -Upper to tail } } result set result } {Error in "delegate option -Upper...", badly named option "-Upper"} test option-4.6 {delegated option name may not contain spaces} { cleanup catch { type dog { delegate option {"-with space"} to tail } } result set result } {Error in "delegate option {"-with space"}...", badly named option "-with space"} test option-5.1 {local widget options read from option database} tk { cleanup 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 } {a bb} test option-5.2 {local option database values available in constructor} tk { cleanup 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 } {bb} test option-6.1 {if no options, no options variable} { cleanup type dog { variable dummy } dog spot spot info vars options } {} test option-6.2 {if no options, no options methods} { cleanup type dog { variable dummy } dog spot spot info methods c* } {} #----------------------------------------------------------------------- # onconfigure test onconfigure-1.1 {invalid onconfigure methods are caught} {} { cleanup catch { type dog { onconfigure -color {value} { } } } result set result } {onconfigure -color: option "-color" unknown} test onconfigure-1.2 {onconfigure methods take one argument} {} { cleanup catch { type dog { option -color golden onconfigure -color {value badarg} { } } } result set result } {onconfigure -color handler should have one argument, got "value badarg"} test onconfigure-1.3 {onconfigure methods work} {} { cleanup type dog { option -color golden onconfigure -color {value} { set options(-color) "*$value*" } } dog create spot spot configure -color brown spot cget -color } {*brown*} test onconfigure-1.4 {onconfigure arg can't be type} {} { cleanup catch { type dog { option -color onconfigure -color {type} { } } } result set result } {onconfigure -color's arglist may not contain "type" explicitly} test onconfigure-1.5 {onconfigure arg can't be self} {} { cleanup catch { type dog { option -color onconfigure -color {self} { } } } result set result } {onconfigure -color's arglist may not contain "self" explicitly} #----------------------------------------------------------------------- # oncget test oncget-1.1 {invalid oncget methods are caught} {} { cleanup catch { type dog { oncget -color { } } } result set result } {Error in "oncget -color...", option "-color" unknown} test oncget-1.2 {oncget methods work} {} { cleanup type dog { option -color golden oncget -color { return "*$options(-color)*" } } dog create spot spot configure -color brown spot cget -color } {*brown*} #----------------------------------------------------------------------- # constructor test constructor-1.1 {constructor can do things} {} { cleanup type dog { variable a variable b constructor {args} { set a 1 set b 2 } method foo {} { list $a $b } } dog create spot spot foo } {1 2} test constructor-1.2 {constructor with no configurelist ignores args} {} { cleanup type dog { constructor {args} { } option -color golden option -akc 0 } dog create spot -color white -akc 1 list [spot cget -color] [spot cget -akc] } {golden 0} test constructor-1.3 {constructor with configurelist gets args} {} { cleanup 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] } {white 1} test constructor-1.4 {constructor with specific args} {} { cleanup type dog { option -value "" constructor {a b args} { set options(-value) [list $a $b $args] } } dog spot retriever golden -akc 1 spot cget -value } {retriever golden {-akc 1}} test constructor-1.5 {constructor with list as one list arg} {} { cleanup type dog { option -value "" constructor {args} { set options(-value) $args } } dog spot {retriever golden} spot cget -value } {{retriever golden}} test constructor-1.6 {default constructor configures options} {} { cleanup type dog { option -color brown option -breed mutt } dog spot -color golden -breed retriever list [spot cget -color] [spot cget -breed] } {golden retriever} test constructor-1.7 {default constructor takes no args if no options} {} { cleanup type dog { variable color } catch {dog spot -color golden} result set result } {Error in constructor: wrong # args: should be "::dog::Snit_constructor type selfns win self"} #----------------------------------------------------------------------- # destroy test destroy-1.1 {destroy cleans up the instance} {} { cleanup 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] } {{} ::dog::Snit_inst1 {} {}} test destroy-1.2 {incomplete objects are destroyed} {} { cleanup 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] } {{Error in constructor: No Red Dogs!} {} {}} test destroy-1.3 {user-defined destructors are called} {} { cleanup 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] } {{created ::spot} {destroyed ::spot}} #----------------------------------------------------------------------- # delegate: general syntax tests test delegate-1.1 {can only delegate methods or options} {} { cleanup set result "" catch { type dog { delegate foo bar to baz } } result set result } {Error in "delegate foo bar...", "foo"?} test delegate-1.2 {"to" must appear in the right place} {} { cleanup set result "" catch { type dog { delegate method foo from bar } } result set result } {Error in "delegate method foo...", unknown delegation option "from"} test delegate-1.3 {"as" must have a target} {} { cleanup set result "" catch { type dog { delegate method foo to bar as } } result set result } {Error in "delegate method foo...", invalid syntax} test delegate-1.4 {"as" must have a single target} {} { cleanup set result "" catch { type dog { delegate method foo to bar as baz quux } } result set result } {Error in "delegate method foo...", unknown delegation option "quux"} test delegate-1.5 {"as" doesn't work with "*"} {} { cleanup set result "" catch { type dog { delegate method * to hull as foo } } result set result } {Error in "delegate method *...", cannot specify "as" with "*"} test delegate-1.6 {"except" must have a target} {} { cleanup set result "" catch { type dog { delegate method * to bar except } } result set result } {Error in "delegate method *...", invalid syntax} test delegate-1.7 {"except" must have a single target} {} { cleanup set result "" catch { type dog { delegate method * to bar except baz quux } } result set result } {Error in "delegate method *...", unknown delegation option "quux"} test delegate-1.8 {"except" works only with "*"} {} { cleanup set result "" catch { type dog { delegate method foo to hull except bar } } result set result } {Error in "delegate method foo...", can only specify "except" with "*"} test delegate-1.9 {only "as" or "except"} {} { cleanup set result "" catch { type dog { delegate method foo to bar with quux } } result set result } {Error in "delegate method foo...", unknown delegation option "with"} #----------------------------------------------------------------------- # delegated methods test dmethod-1.1 {delegate method to non-existent component} {} { cleanup set result "" type dog { delegate method foo to bar } dog create spot catch {spot foo} result set result } {::dog ::spot delegates method "foo" to undefined component "bar"} test dmethod-1.2 {delegating to existing component} { cleanup type dog { constructor {args} { set string string } delegate method length to string } dog create spot spot length foo } {3} test dmethod-1.3 {delegating to existing component with error} { cleanup type dog { constructor {args} { set string string } delegate method length to string } dog create spot set result "" catch {spot length foo bar} result set result } {wrong # args: should be "string length string"} test dmethod-1.4 {delegating unknown methods to existing component} { cleanup type dog { constructor {args} { set string string } delegate method * to string } dog create spot spot length foo } {3} test dmethod-1.5 {delegating unknown method to existing component with error} { cleanup type dog { constructor {args} { set stringhandler string } delegate method * to stringhandler } dog create spot set result "" catch {spot foo bar} result set result } {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} test dmethod-1.6 {can't delegate local method: order 1} { cleanup catch { type cat { method foo {} {} delegate method foo to hull } } result set result } {Error in "delegate method foo...", "foo" has been defined locally.} test dmethod-1.7 {can't delegate local method: order 2} { cleanup catch { type cat { delegate method foo to hull method foo {} {} } } result set result } {Error in "method foo...", "foo" has been delegated} test dmethod-1.8 {excepted methods are caught properly} { cleanup 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 } {flaunted {"::fifi wag" is not defined} {"::fifi tuck" is not defined}} test dmethod-1.9 {as clause can include arguments} { cleanup 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 } {wagged briskly} test dmethod-2.1 {'using "%c %m"' gets normal behavior} { cleanup 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 } {wagged briskly} test dmethod-2.2 {All 'using' conversions are converted} { cleanup 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 } {% ::dog {tail wag} wag tail_wag ::dog::Snit_inst1 ::spot ::spot %c} test dmethod-2.3 {"%%" is handled properly} { cleanup proc echo {args} { join $args "|" } type dog { delegate method wag using {echo %%m %%%m} } dog spot spot wag } {%m|%wag} test dmethod-2.4 {Method "*" and "using"} { cleanup proc echo {args} { join $args "|" } type dog { delegate method * using {echo %m} } dog spot list [spot wag] [spot bark loudly] } {wag bark|loudly} test dmethod-3.1 {component names can be changed dynamically} { cleanup 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 } {wagged drooped} test dmethod-4.1 {hierarchical method, two tokens} {} { cleanup type tail { method wag {} {return "wags tail"} } type dog { constructor {} { set tail [tail] } delegate method {wag tail} to tail as wag } dog spot spot wag tail } {wags tail} test dmethod-4.2 {hierarchical method, three tokens} {} { cleanup type tail { method wag {} {return "wags tail"} } type dog { constructor {} { set tail [tail] } delegate method {wag tail proudly} to tail as wag } dog spot spot wag tail proudly } {wags tail} test dmethod-4.3 {hierarchical method, three tokens} {} { cleanup type tail { method wag {} {return "wags tail"} } type dog { constructor {} { set tail [tail] } delegate method {wag tail really high} to tail as wag } dog spot spot wag tail really high } {wags tail} test dmethod-4.4 {redefinition is OK} {} { cleanup type tail { method {wag tail} {} {return "wags tail"} method {wag briskly} {} {return "wags tail briskly"} } type dog { constructor {} { set tail [tail] } delegate method {wag tail} to tail as {wag tail} delegate method {wag tail} to tail as {wag briskly} } dog spot spot wag tail } {wags tail briskly} test dmethod-4.5 {all tokens are used by default} {} { cleanup type tail { method wag {} {return "wags tail"} } type dog { constructor {} { set tail [tail] } delegate method {tail wag} to tail } dog spot spot tail wag } {wags tail} test dmethod-4.6 {last token can be *} {} { cleanup type tail { method wag {} {return "wags"} method droop {} {return "droops"} } type dog { constructor {} { set tail [tail] } delegate method {tail *} to tail } dog spot list [spot tail wag] [spot tail droop] } {wags droops} test dmethod-4.7 {except with multiple tokens} {} { cleanup type tail { method wag {} {return "wags"} method droop {} {return "droops"} } type dog { constructor {} { set tail [tail] } delegate method {tail *} to tail except droop } dog spot catch {spot tail droop} result list [spot tail wag] $result } {wags {"::spot tail droop" is not defined}} test dmethod-4.8 {"*" in the wrong spot} {} { cleanup catch { type dog { delegate method {tail * wag} to tail } } result set result } {Error in "delegate method {tail * wag}...", "*" must be the last token.} test dmethod-5.1 {prefix/method collision} {} { cleanup catch { type dog { delegate method wag to tail delegate method {wag tail} to tail as wag } } result set result } {Error in "delegate method {wag tail}...", "wag" has no submethods.} test dmethod-5.2 {prefix/method collision} {} { cleanup catch { type dog { delegate method {wag tail} to tail as wag delegate method wag to tail } } result set result } {Error in "delegate method wag...", "wag" has submethods.} test dmethod-5.3 {prefix/method collision} {} { cleanup catch { type dog { delegate method {wag tail} to tail delegate method {wag tail proudly} to tail as wag } } result set result } {Error in "delegate method {wag tail proudly}...", "wag tail" has no submethods.} test dmethod-5.4 {prefix/method collision} {} { cleanup catch { type dog { delegate method {wag tail proudly} to tail as wag delegate method {wag tail} to tail } } result set result } {Error in "delegate method {wag tail}...", "wag tail" has submethods.} #----------------------------------------------------------------------- # delegated options test doption-1.1 {delegate option to non-existent component} {} { cleanup set result "" type dog { delegate option -foo to bar } dog create spot catch {spot cget -foo} result set result } {component "bar" is undefined in ::dog ::spot} test doption-1.2 {delegating option to existing component: cget} { cleanup 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 } {black} test doption-1.3 {delegating option to existing component: configure} { cleanup 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] } {blue blue} test doption-1.4 {delegating unknown options to existing component} { cleanup 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] } {blue blue} test doption-1.5 {can't oncget for delegated option} { cleanup set result "" catch { type dog { delegate option -color to catthing oncget -color { } } } result set result } {Error in "oncget -color...", option "-color" is delegated} test doption-1.6 {can't onconfigure for delegated option} { cleanup set result "" catch { type dog { delegate option -color to catthing onconfigure -color {value} { } } } result set result } {onconfigure -color: option "-color" is delegated} test doption-1.7 {delegating unknown options to existing component: error} { cleanup type cat { option -color "black" } cat create hershey type dog { constructor {args} { set catthing ::hershey $self configurelist $args } delegate option * to catthing } set result {} catch {dog create spot -colour blue} result set result } {Error in constructor: unknown option "-colour"} test doption-1.8 {can't delegate local option: order 1} { cleanup catch { type cat { option -color "black" delegate option -color to hull } } result set result } {Error in "delegate option -color...", "-color" has been defined locally} test doption-1.9 {can't delegate local option: order 2} { cleanup catch { type cat { delegate option -color to hull option -color "black" } } result set result } {Error in "option -color...", cannot define "-color" locally, it has been delegated} test doption-1.10 {excepted options are caught properly on cget} { cleanup 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 } {a {unknown option "-b"} {unknown option "-c"}} test doption-1.11 {excepted options are caught properly on configurelist} { cleanup 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 } {{} {unknown option "-b"} {unknown option "-c"}} test doption-1.12 {excepted options are caught properly on configure, 1} { cleanup 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 } {{} {unknown option "-b"} {unknown option "-c"}} test doption-1.13 {excepted options are caught properly on configure, 2} { cleanup 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 } {{-a a A a a} {unknown option "-b"} {unknown option "-c"}} test doption-1.14 {configure query skips excepted options} { cleanup 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 } {{-d d D d d} {-a a A a a}} #----------------------------------------------------------------------- # from test from-1.1 {getting default values} { cleanup 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] } {AAA BAR} test from-1.2 {getting non-default values} { cleanup 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] } {quux frobozz {-baz frobnitz}} #----------------------------------------------------------------------- # Widgetadaptors test widgetadaptor-1.1 {creating a widget: hull hijacking} tk { cleanup widgetadaptor mylabel { constructor {args} { installhull [label $self] $self configurelist $args } method hull {} { return $hull] } 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 } {{My Label} {My Label}} test widgetadaptor-1.2 {destroying a widget with destroy} tk { cleanup 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 } {::mylabel::Snit_inst1 {}} test widgetadaptor-1.3 {destroying two widgets of the same type with destroy} tk { cleanup 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 } {{::mylabel::Snit_inst1 ::mylabel::Snit_inst2} {}} test widgetadaptor-1.4 {destroying a widget with rename, then destroy type} tk { cleanup 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 } {::mylabel::Snit_inst1 {}} test widgetadaptor-1.5 {destroying two widgets of the same type with rename} tk { cleanup 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 } {{::mylabel::Snit_inst1 ::mylabel::Snit_inst2} {}} test widgetadaptor-1.6 {create/destroy twice, with destroy} tk { cleanup 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 } {::mylabel::Snit_inst1 ::mylabel::Snit_inst2 {}} test widgetadaptor-1.7 {create/destroy twice, with rename} tk { cleanup 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 } {::mylabel::Snit_inst1 ::mylabel::Snit_inst2 {}} test widgetadaptor-1.8 {"create" is optional} tk { cleanup widgetadaptor mylabel { constructor {args} { installhull [label $self] } method howdy {} {return "Howdy!"} } mylabel .label set a [.label howdy] destroy .label tkbide set a } {Howdy!} test widgetadaptor-1.9 {"create" is optional, but must be a valid name} tk { cleanup widgetadaptor mylabel { constructor {args} { installhull [label $self] } method howdy {} {return "Howdy!"} } catch {mylabel foo} result tkbide set result } {"::mylabel foo" is not defined} test widgetadaptor-1.10 {user-defined destructors are called} tk { cleanup 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] } {{created .label} {destroyed .label}} test widgetadaptor-1.11 {destroy method not defined for widget types} tk { cleanup widgetadaptor mylabel { constructor {args} { installhull [label $self] } } mylabel .label catch {.label destroy} result destroy .label tkbide set result } {".label destroy" is not defined} test widgetadaptor-1.12 {hull can be repeatedly renamed} tk { cleanup 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] tkbide set a } {.foo} test widgetadaptor-1.13 {widget names can be generated} tk { cleanup # Don't use this widget type name in any other test. widgetadaptor unique { constructor {args} { installhull [label $self] } } set w [unique .%AUTO%] destroy $w tkbide set w } {.unique1} test widgetadaptor-1.14 {snit::widgetadaptor as hull} tk { cleanup 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 } {{method2: method1} {Some Text} {More Text} ::mylabel2::Snit_inst1 ::mylabel::Snit_inst1 {} {}} test widgetadaptor-1.15 {snit::widgetadaptor as hull; use rename} tk { cleanup 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 } {{method2: method1} {Some Text} {More Text} ::mylabel2::Snit_inst1 ::mylabel::Snit_inst1 {} {}} test widgetadaptor-1.16 {BWidget Label as hull} bwidget { cleanup 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 } {{Some Text} {More Text} ::mylabel::Snit_inst1 {}} test widgetadaptor-1.17 {error in widgetadaptor constructor} tk { cleanup widgetadaptor mylabel { constructor {args} { error "Simulated Error" } } catch {mylabel .lab} result set 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} tk { cleanup 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 } {green ::hull1.frm} test widget-2.1 {can't redefine hull} tk { cleanup widget myframe { method resethull {} { set hull "" } } myframe .frm catch {.frm resethull} result set 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} tk { cleanup 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 } {green} test install-1.2 {installed components are saved properly} tk { cleanup 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 } {green} test install-1.3 {can't install until hull exists} tk { cleanup 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 } } catch { myframe .frm } result set result } {Error in constructor: tried to install "text" before the hull exists} test install-1.4 {install queries option database} tk { cleanup 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 } {Courier} test install-1.5 {explicit options override option database} tk { cleanup 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 } {Times} test install-1.6 {option db works with targetted options} tk { cleanup 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 } {Courier} test install-1.7 {install works for snit::types} { cleanup 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 } {black} test install-1.8 {install can install non-widget components} tk { cleanup 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 } {green} test install-1.9 {ok if no options are delegated to component} tk { cleanup 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 } {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. } tk { cleanup 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 } {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. } tk { cleanup 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 {$a ne $b} } {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. } tk { cleanup 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 } {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. } tk { cleanup 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 } {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. } tk { cleanup 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 } {red 123} test installhull-1.2 { Options delegated to a widget's hull frame with a different name are initialized from the option database. } tk { cleanup 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 } {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. } tk { cleanup 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 } {red 123} test installhull-1.4 { Options delegated to a widget's hull frame with a different name are initialized from the option database. } tk { cleanup 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 } {red} test installhull-1.4 { Option values read from the option database are overridden by options explicitly passed, even if delegated under a different name. } tk { cleanup 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 } {green 321} #----------------------------------------------------------------------- # Instance Introspection test iinfo-1.1 {object info too few args} { cleanup type dog { } dog create spot catch {spot info} result set result } {wrong # args: should be "::snit::RT.method.info type selfns win self command args"} test iinfo-1.2 {object info too many args} { cleanup type dog { } dog create spot catch {spot info type foo} result set result } {wrong # args: should be "::snit::RT.method.info.type type selfns win self"} test iinfo-2.1 {object info type} { cleanup type dog { } dog create spot spot info type } {::dog} test iinfo-3.1 {object info typevars} { cleanup type dog { typevariable thisvar 1 constructor {args} { typevariable thatvar 2 } } dog create spot lsort [spot info typevars] } {::dog::thatvar ::dog::thisvar} test iinfo-3.2 {object info typevars with pattern} { cleanup type dog { typevariable thisvar 1 constructor {args} { typevariable thatvar 2 } } dog create spot spot info typevars *this* } {::dog::thisvar} test iinfo-4.1 {object info vars} { cleanup type dog { variable hisvar 1 constructor {args} { variable hervar set hervar 2 } } dog create spot lsort [spot info vars] } {::dog::Snit_inst1::hervar ::dog::Snit_inst1::hisvar} test iinfo-4.2 {object info vars with pattern} { cleanup type dog { variable hisvar 1 constructor {args} { variable hervar set hervar 2 } } dog create spot spot info vars "*his*" } {::dog::Snit_inst1::hisvar} test iinfo-5.1 {object info no vars defined} { cleanup type dog { } dog create spot list [spot info vars] [spot info typevars] } {{} {}} test iinfo-6.1 {info options with no options} { cleanup type dog { } dog create spot llength [spot info options] } {0} test iinfo-6.2 {info options with only local options} { cleanup type dog { option -foo a option -bar b } dog create spot lsort [spot info options] } {-bar -foo} test iinfo-6.3 {info options with local and delegated options} { cleanup type dog { option -foo a option -bar b delegate option -quux to sibling } dog create spot lsort [spot info options] } {-bar -foo -quux} test iinfo-6.4 {info options with unknown delegated options} tk { cleanup 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 } {-background -bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief -takefocus -visual -width} test iinfo-6.5 {info options with exceptions} tk { cleanup 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 } {-bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief -takefocus -visual -width} test iinfo-6.6 {info options with pattern} tk { cleanup 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 } {-class -colormap -container -cursor} test iinfo-7.1 {info typemethods, simple case} { cleanup type dog { } dog spot lsort [spot info typemethods] } {create destroy info} test iinfo-7.2 {info typemethods, with pattern} { cleanup type dog { } dog spot spot info typemethods i* } {info} test iinfo-7.3 {info typemethods, with explicit typemethods} { cleanup type dog { typemethod foo {} {} delegate typemethod bar to comp } dog spot lsort [spot info typemethods] } {bar create destroy foo info} test iinfo-7.4 {info typemethods, with implicit typemethods} { cleanup 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 } {{create destroy info} {create destroy info is length} length} test iinfo-7.5 {info typemethods, with hierarchical typemethods} { cleanup type dog { delegate typemethod {comp foo} to comp typemethod {comp bar} {} {} } dog create spot lsort [spot info typemethods] } {{comp bar} {comp foo} create destroy info} test iinfo-8.1 {info methods, simple case} { cleanup type dog { } dog spot lsort [spot info methods] } {destroy info} test iinfo-8.2 {info methods, with pattern} { cleanup type dog { } dog spot spot info methods i* } {info} test iinfo-8.3 {info methods, with explicit methods} { cleanup type dog { method foo {} {} delegate method bar to comp } dog spot lsort [spot info methods] } {bar destroy foo info} test iinfo-8.4 {info methods, with implicit methods} { cleanup 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 } {{destroy info} {destroy info is length} length} test iinfo-8.5 {info methods, with hierarchical methods} { cleanup type dog { delegate method {comp foo} to comp method {comp bar} {} {} } dog create spot lsort [spot info methods] } {{comp bar} {comp foo} destroy info} #----------------------------------------------------------------------- # Type Introspection test tinfo-1.1 {type info too few args} { cleanup type dog { } catch {dog info} result set result } {wrong # args: should be "::snit::RT.typemethod.info type command args"} test tinfo-1.2 {type info too many args} { cleanup type dog { } catch {dog info instances foo bar} result set result } {wrong # args: should be "::snit::RT.typemethod.info.instances type ?pattern?"} test tinfo-2.1 {type info typevars} { cleanup type dog { typevariable thisvar 1 constructor {args} { typevariable thatvar 2 } } dog create spot lsort [dog info typevars] } {::dog::thatvar ::dog::thisvar} test tinfo-3.1 {type info instances} { cleanup type dog { } dog create spot dog create fido lsort [dog info instances] } {::fido ::spot} test tinfo-3.2 {widget info instances} tk { cleanup widgetadaptor mylabel { constructor {args} { installhull [label $self] } } mylabel .lab1 mylabel .lab2 set result [mylabel info instances] destroy .lab1 destroy .lab2 tkbide lsort $result } {.lab1 .lab2} test tinfo-3.3 {type info instances with non-global namespaces} { cleanup type dog { } dog create ::spot namespace eval ::dogs:: { set ::qname [dog create fido] } list $qname [lsort [dog info instances]] } {::dogs::fido {::dogs::fido ::spot}} test tinfo-3.4 {type info instances with pattern} { cleanup type dog { } dog create spot dog create fido dog info instances "*f*" } {::fido} test tinfo-4.1 {type info typevars with pattern} { cleanup type dog { typevariable thisvar 1 constructor {args} { typevariable thatvar 2 } } dog create spot dog info typevars *this* } {::dog::thisvar} test tinfo-5.1 {type info typemethods, simple case} { cleanup type dog { } lsort [dog info typemethods] } {create destroy info} test tinfo-5.2 {type info typemethods, with pattern} { cleanup type dog { } dog info typemethods i* } {info} test tinfo-5.3 {type info typemethods, with explicit typemethods} { cleanup type dog { typemethod foo {} {} delegate typemethod bar to comp } lsort [dog info typemethods] } {bar create destroy foo info} test tinfo-5.4 {type info typemethods, with implicit typemethods} { cleanup 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 } {{create destroy info} {create destroy info is length} length} test tinfo-5.5 {info typemethods, with hierarchical typemethods} { cleanup type dog { delegate typemethod {comp foo} to comp typemethod {comp bar} {} {} } lsort [dog info typemethods] } {{comp bar} {comp foo} create destroy info} #----------------------------------------------------------------------- # Setting the widget class explicitly test widgetclass-1.1 {can't set widgetclass for snit::types} { cleanup catch { type dog { widgetclass Dog } } result set result } {widgetclass cannot be set for snit::types} test widgetclass-1.2 {can't set widgetclass for snit::widgetadaptors} tk { cleanup catch { widgetadaptor dog { widgetclass Dog } } result set result } {widgetclass cannot be set for snit::widgetadaptors} test widgetclass-1.3 {widgetclass must begin with uppercase letter} tk { cleanup catch { widget dog { widgetclass dog } } result set result } {widgetclass "dog" does not begin with an uppercase letter} test widgetclass-1.4 {widgetclass can only be defined once} tk { cleanup catch { widget dog { widgetclass Dog widgetclass Dog } } result set result } {too many widgetclass statements} test widgetclass-1.5 {widgetclass set successfully} tk { cleanup widget dog { widgetclass DogWidget } # The test passes if no error is thrown. list ok } {ok} test widgetclass-1.6 {implicit widgetclass applied to hull} tk { cleanup widget dog { typeconstructor { option add *Dog.background green } method background {} { $hull cget -background } } dog .dog set bg [.dog background] destroy .dog set bg } {green} test widgetclass-1.7 {explicit widgetclass applied to hull} tk { cleanup 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 } {green} #----------------------------------------------------------------------- # hulltype statement test hulltype-1.1 {can't set hulltype for snit::types} { cleanup catch { type dog { hulltype Dog } } result set result } {hulltype cannot be set for snit::types} test hulltype-1.2 {can't set hulltype for snit::widgetadaptors} tk { cleanup catch { widgetadaptor dog { hulltype Dog } } result set result } {hulltype cannot be set for snit::widgetadaptors} test hulltype-1.3 {hulltype can be frame} tk { cleanup widget dog { delegate option * to hull hulltype frame } dog .fido catch {.fido configure -use} result destroy .fido tkbide set result } {unknown option "-use"} test hulltype-1.4 {hulltype can be toplevel} tk { cleanup widget dog { delegate option * to hull hulltype toplevel } dog .fido catch {.fido configure -use} result destroy .fido tkbide set result } {-use use Use {} {}} test hulltype-1.5 {hulltype can only be defined once} tk { cleanup catch { widget dog { hulltype frame hulltype toplevel } } result set result } {too many hulltype statements} #----------------------------------------------------------------------- # expose statement test expose-1.1 {can't expose nothing} { cleanup catch { type dog { expose } } result set result } {wrong # args: should be "::snit::Comp.statement.expose component ?as? ?methodname?"} test expose-1.2 {expose a component that's never installed} { cleanup type dog { expose tail } dog fido catch { fido tail wag } result set result } {undefined component "tail"} test expose-1.3 {exposed method returns component command} { cleanup type tail { } type dog { expose tail constructor {} { install tail using tail $self.tail } destructor { $tail destroy } } dog fido fido tail } {::fido.tail} test expose-1.4 {exposed method calls component methods} { cleanup 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] } {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} { cleanup type dog { typemethod generr {} { error bogusError bogusInfo bogusCode } } catch {dog generr} result global errorInfo errorCode list $result [string match "*bogusInfo*" $errorInfo] $errorCode } {bogusError 1 bogusCode} test error-1.2 {snit::type constructor errors propagate properly} { cleanup type dog { constructor {} { error bogusError bogusInfo bogusCode } } catch {dog fido} result global errorInfo errorCode list $result [string match "*bogusInfo*" $errorInfo] $errorCode } {{Error in constructor: bogusError} 1 bogusCode} test error-1.3 {snit::widget constructor errors propagate properly} tk { cleanup widget dog { constructor {args} { error bogusError bogusInfo bogusCode } } catch {dog .fido} result global errorInfo errorCode list $result [string match "*bogusInfo*" $errorInfo] $errorCode } {{Error in constructor: bogusError} 1 bogusCode} test error-1.4 {method errors propagate properly} { cleanup type dog { method generr {} { error bogusError bogusInfo bogusCode } } dog fido catch {fido generr} result global errorInfo errorCode list $result [string match "*bogusInfo*" $errorInfo] $errorCode } {bogusError 1 bogusCode} test error-1.5 {onconfigure errors propagate properly} { cleanup 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 } {bogusError 1 bogusCode} test error-1.6 {oncget errors propagate properly} { cleanup 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 } {bogusError 1 bogusCode} #----------------------------------------------------------------------- # Externally defined typemethods test etypemethod-1.1 {external typemethods can be called as expected} { cleanup type dog { } typemethod dog foo {a} {return "+$a+"} dog foo bar } {+bar+} test etypemethod-1.2 {external typemethods can use typevariables} { cleanup type dog { typevariable somevar "Howdy" } typemethod dog getvar {} {return $somevar} dog getvar } {Howdy} test etypemethod-1.3 {typemethods can be redefined dynamically} { cleanup type dog { typemethod foo {} { return "foo" } } set a [dog foo] typemethod dog foo {} { return "bar"} set b [dog foo] list $a $b } {foo bar} test etypemethod-1.4 {can't define external typemethod if no type} { cleanup catch { typemethod extremelyraredog foo {} { return "bar"} } result set result } {no such type: "extremelyraredog"} test etypemethod-2.1 {external hierarchical method, two tokens} {} { cleanup type dog { } typemethod dog {wag tail} {} { return "wags tail" } dog wag tail } {wags tail} test etypemethod-2.2 {external hierarchical method, three tokens} {} { cleanup type dog { } typemethod dog {wag tail proudly} {} { return "wags tail proudly" } dog wag tail proudly } {wags tail proudly} test etypemethod-2.3 {external hierarchical method, three tokens} {} { cleanup type dog { } typemethod dog {wag tail really high} {} { return "wags tail really high" } dog wag tail really high } {wags tail really high} test etypemethod-2.4 {redefinition is OK} {} { cleanup type dog { } typemethod dog {wag tail} {} { return "wags tail" } typemethod dog {wag tail} {} { return "wags tail briskly" } dog wag tail } {wags tail briskly} test etypemethod-3.1 {prefix/method collision} {} { cleanup type dog { typemethod wag {} {} } catch { typemethod dog {wag tail} {} {} } result set result } {Cannot define "wag tail", "wag" has no submethods.} test etypemethod-3.2 {prefix/method collision} {} { cleanup type dog { typemethod {wag tail} {} {} } catch { typemethod dog wag {} {} } result set result } {Cannot define "wag", "wag" has submethods.} test etypemethod-3.3 {prefix/method collision} {} { cleanup type dog { typemethod {wag tail} {} {} } catch { typemethod dog {wag tail proudly} {} {} } result set result } {Cannot define "wag tail proudly", "wag tail" has no submethods.} test etypemethod-3.4 {prefix/method collision} {} { cleanup type dog { typemethod {wag tail proudly} {} {} } catch { typemethod dog {wag tail} {} {} } result set result } {Cannot define "wag tail", "wag tail" has submethods.} #----------------------------------------------------------------------- # Externally defined methods test emethod-1.1 {external methods can be called as expected} { cleanup type dog { } method dog bark {a} {return "+$a+"} dog spot spot bark woof } {+woof+} test emethod-1.2 {external methods can use typevariables} { cleanup type dog { typevariable somevar "Hello" } method dog getvar {} {return $somevar} dog spot spot getvar } {Hello} test emethod-1.3 {external methods can use variables} { cleanup type dog { variable somevar "Greetings" } method dog getvar {} {return $somevar} dog spot spot getvar } {Greetings} test emethod-1.4 {methods can be redefined dynamically} { cleanup type dog { method bark {} { return "woof" } } dog spot set a [spot bark] method dog bark {} { return "arf"} set b [spot bark] list $a $b } {woof arf} test emethod-1.5 {delegated methods can't be redefined} { cleanup type dog { delegate method bark to someotherdog } catch { method dog bark {} { return "arf"} } result set result } {Cannot define "bark", "bark" has been delegated} test emethod-1.6 {can't define external method if no type} { cleanup catch { method extremelyraredog foo {} { return "bar"} } result set result } {no such type: "extremelyraredog"} test emethod-2.1 {external hierarchical method, two tokens} {} { cleanup type dog { } method dog {wag tail} {} { return "$self wags tail." } dog spot spot wag tail } {::spot wags tail.} test emethod-2.2 {external hierarchical method, three tokens} {} { cleanup type dog { } method dog {wag tail proudly} {} { return "$self wags tail proudly." } dog spot spot wag tail proudly } {::spot wags tail proudly.} test emethod-2.3 {external hierarchical method, three tokens} {} { cleanup type dog { } method dog {wag tail really high} {} { return "$self wags tail really high." } dog spot spot wag tail really high } {::spot wags tail really high.} test emethod-2.4 {redefinition is OK} {} { cleanup type dog { } method dog {wag tail} {} { return "$self wags tail." } method dog {wag tail} {} { return "$self wags tail briskly." } dog spot spot wag tail } {::spot wags tail briskly.} test emethod-3.1 {prefix/method collision} {} { cleanup type dog { method wag {} {} } catch { method dog {wag tail} {} { return "$self wags tail." } } result set result } {Cannot define "wag tail", "wag" has no submethods.} test emethod-3.2 {prefix/method collision} {} { cleanup type dog { method {wag tail} {} { return "$self wags tail." } } catch { method dog wag {} {} } result set result } {Cannot define "wag", "wag" has submethods.} test emethod-3.3 {prefix/method collision} {} { cleanup type dog { method {wag tail} {} {} } catch { method dog {wag tail proudly} {} { return "$self wags tail." } } result set result } {Cannot define "wag tail proudly", "wag tail" has no submethods.} test emethod-3.4 {prefix/method collision} {} { cleanup type dog { method {wag tail proudly} {} { return "$self wags tail." } } catch { method dog {wag tail} {} {} } result set result } {Cannot define "wag tail", "wag tail" has submethods.} #----------------------------------------------------------------------- # Macros test macro-1.1 {can't redefine non-macros} { cleanup catch { snit::macro method {} {} } result set result } {invalid macro name "method"} test macro-1.2 {can define and use a macro} { cleanup snit::macro hello {name} { method hello {} "return {Hello, $name!}" } type dog { hello World } dog spot spot hello } {Hello, World!} test macro-1.3 {can redefine macro} { cleanup snit::macro dup {} {} snit::macro dup {} {} set dummy "No error" } {No error} test macro-1.4 {can define macro in namespace} { cleanup snit::macro ::test::goodbye {name} { method goodbye {} "return {Goodbye, $name!}" } type dog { ::test::goodbye World } dog spot spot goodbye } {Goodbye, World!} test macro-1.5 {_proc and _variable are defined} { cleanup 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 } {_variable _proc} test macro-1.6 {_variable works} { cleanup snit::macro test1 {} { _variable myvar "_variable works" } snit::macro test2 {} { _variable myvar method testit {} "return {$myvar}" } type dog { test1 test2 } dog spot spot testit } {_variable works} #----------------------------------------------------------------------- # Component Statement test component-1.1 {component defines an instance variable} { cleanup type dog { component tail } dog spot namespace tail [spot info vars tail] } {tail} test component-1.2 {-public exposes the component} { cleanup type tail { method wag {} { return "Wag, wag" } } type dog { component tail -public mytail constructor {} { set tail [tail %AUTO%] } } dog spot spot mytail wag } {Wag, wag} test component-1.3 {-inherit requires a boolean value} { cleanup catch { type dog { component animal -inherit foo } } result set result } {component animal -inherit: expected boolean value, got "foo"} test component-1.4 {-inherit delegates unknown methods to the component} { cleanup type animal { method eat {} { return "Eat, eat." } } type dog { component animal -inherit yes constructor {} { set animal [animal %AUTO%] } } dog spot spot eat } {Eat, eat.} test component-1.5 {-inherit delegates unknown options to the component} { cleanup type animal { option -size medium } type dog { component animal -inherit yes constructor {} { set animal [animal %AUTO%] } } dog spot spot cget -size } {medium} #----------------------------------------------------------------------- # Typevariables, Variables, Typecomponents, Components test typevar_var-1.1 {variable/typevariable collisions not allowed: order 1} { cleanup catch { type dog { typevariable var variable var } } result set result } {Error in "variable var...", "var" is already a typevariable} test typevar_var-1.2 {variable/typevariable collisions not allowed: order 2} { cleanup catch { type dog { variable var typevariable var } } result set result } {Error in "typevariable var...", "var" is already an instance variable} test typevar_var-1.3 {component/typecomponent collisions not allowed: order 1} { cleanup catch { type dog { typecomponent comp component comp } } result set result } {Error in "component comp...", "comp" is already a typevariable} test typevar_var-1.4 {component/typecomponent collisions not allowed: order 2} { cleanup catch { type dog { component comp typecomponent comp } } result set result } {Error in "typecomponent comp...", "comp" is already an instance variable} test typevar_var-1.5 {can't delegate options to typecomponents} { cleanup catch { type dog { typecomponent comp delegate option -opt to comp } } result set result } {Error in "delegate option -opt...", "comp" is already a typevariable} test typevar_var-1.5 {can't delegate typemethods to instance components} { cleanup catch { type dog { component comp delegate typemethod foo to comp } } result set result } {Error in "delegate typemethod foo...", "comp" is already an instance variable} test typevar_var-1.6 {can delegate methods to typecomponents} { cleanup proc echo {args} {return [join $args "|"]} type dog { typecomponent tail typeconstructor { set tail echo } delegate method wag to tail } dog spot spot wag briskly } {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} { cleanup type dog { option -foo option -bar } set ::dog::Snit_optionInfo(local) } {-foo -bar} test optionsyntax-1.2 {islocal flag is set} { cleanup type dog { option -foo } set ::dog::Snit_optionInfo(islocal--foo) } {1} test optionsyntax-2.1 {implicit resource and class} { cleanup type dog { option -foo } list \ $::dog::Snit_optionInfo(resource--foo) \ $::dog::Snit_optionInfo(class--foo) } {foo Foo} test optionsyntax-2.2 {explicit resource, default class} { cleanup type dog { option {-foo ffoo} } list \ $::dog::Snit_optionInfo(resource--foo) \ $::dog::Snit_optionInfo(class--foo) } {ffoo Ffoo} test optionsyntax-2.3 {explicit resource and class} { cleanup type dog { option {-foo ffoo FFoo} } list \ $::dog::Snit_optionInfo(resource--foo) \ $::dog::Snit_optionInfo(class--foo) } {ffoo FFoo} test optionsyntax-2.4 {can't redefine explicit resource} { cleanup catch { type dog { option {-foo ffoo} option {-foo foo} } } result set result } {Error in "option {-foo foo}...", resource name redefined from "ffoo" to "foo"} test optionsyntax-2.5 {can't redefine explicit class} { cleanup catch { type dog { option {-foo ffoo Ffoo} option {-foo ffoo FFoo} } } result set result } {Error in "option {-foo ffoo FFoo}...", class name redefined from "Ffoo" to "FFoo"} test optionsyntax-2.6 {can redefine implicit resource and class} { cleanup type dog { option -foo option {-foo ffoo} option {-foo ffoo FFoo} option -foo } } {::dog} test optionsyntax-3.1 {no default value} { cleanup type dog { option -foo } set ::dog::Snit_optionInfo(default--foo) } {} test optionsyntax-3.2 {default value, old syntax} { cleanup type dog { option -foo bar } set ::dog::Snit_optionInfo(default--foo) } {bar} test optionsyntax-3.3 {option definition options can be set} { cleanup 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) } {Bar Validate Configure Cget 1} test optionsyntax-3.4 {option definition option values accumulate} { cleanup 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) } {Bar Validate Configure Cget 1} test optionsyntax-3.5 {option definition option values can be redefined} { cleanup 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) } {Bar2 Validate2 Configure2 Cget2 0} test optionsyntax-3.6 {option -readonly defaults to 0} { cleanup type dog { option -foo } set ::dog::Snit_optionInfo(readonly--foo) } {0} test optionsyntax-3.7 {option -readonly can be any boolean} { cleanup type dog { option -foo -readonly 0 option -foo -readonly 1 option -foo -readonly y option -foo -readonly n } } {::dog} test optionsyntax-3.8 {option -readonly must be a boolean} { cleanup catch { type dog { option -foo -readonly foo } } result set result } {Error in "option -foo...", -readonly requires a boolean, got "foo"} test optionsyntax-3.9 {option -readonly can't be empty} { cleanup catch { type dog { option -foo -readonly {} } } result set 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} { cleanup type dog { delegate option -foo to comp delegate option -bar to comp } set ::dog::Snit_optionInfo(delegated) } {-foo -bar} test delegateoptionsyntax-1.2 {'delegated' does not include '*'} { cleanup type dog { delegate option * to comp } set ::dog::Snit_optionInfo(delegated) } {} test delegateoptionsyntax-1.3 {'islocal' is set to 0} { cleanup type dog { delegate option -foo to comp } set ::dog::Snit_optionInfo(islocal--foo) } {0} test delegateoptionsyntax-1.4 {'islocal' is not set for '*'} { cleanup type dog { delegate option * to comp } info exists ::dog::Snit_optionInfo(islocal-*) } {0} test delegateoptionsyntax-1.5 {'delegated-$comp' lists options for the component} { cleanup 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) } {{-foo -bar} -baz} test delegateoptionsyntax-1.6 {'except' is empty by default} { cleanup type dog { delegate option -foo to comp } set ::dog::Snit_optionInfo(except) } {} test delegateoptionsyntax-1.7 {'except' lists exceptions} { cleanup type dog { delegate option * to comp except {-foo -bar -baz} } set ::dog::Snit_optionInfo(except) } {-foo -bar -baz} test delegateoptionsyntax-1.8 {'target-$opt' set with default} { cleanup type dog { delegate option -foo to comp } set ::dog::Snit_optionInfo(target--foo) } {comp -foo} test delegateoptionsyntax-1.9 {'target-$opt' set explicitly} { cleanup type dog { delegate option -foo to comp as -bar } set ::dog::Snit_optionInfo(target--foo) } {comp -bar} test delegateoptionsyntax-1.10 {'starcomp' is {} by default} { cleanup type dog { delegate option -foo to comp } set ::dog::Snit_optionInfo(starcomp) } {} test delegateoptionsyntax-1.11 {'starcomp' set for *} { cleanup type dog { delegate option * to comp } set ::dog::Snit_optionInfo(starcomp) } {comp} test delegatedoptionsyntax-2.1 {implicit resource and class} { cleanup type dog { delegate option -foo to comp } list \ $::dog::Snit_optionInfo(resource--foo) \ $::dog::Snit_optionInfo(class--foo) } {foo Foo} test optionsyntax-2.2 {explicit resource, default class} { cleanup type dog { delegate option {-foo ffoo} to comp } list \ $::dog::Snit_optionInfo(resource--foo) \ $::dog::Snit_optionInfo(class--foo) } {ffoo Ffoo} test optionsyntax-2.3 {explicit resource and class} { cleanup type dog { delegate option {-foo ffoo FFoo} to comp } list \ $::dog::Snit_optionInfo(resource--foo) \ $::dog::Snit_optionInfo(class--foo) } {ffoo FFoo} test optionsyntax-2.4 {* doesn't get resource and class} { cleanup type dog { delegate option * to comp } list \ [info exist ::dog::Snit_optionInfo(resource-*)] \ [info exist ::dog::Snit_optionInfo(class-*)] } {0 0} #----------------------------------------------------------------------- # Cget cache test cgetcache-1.1 {Instance rename invalidates cache} { cleanup 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 } {quux} test cgetcache-1.2 {Component rename invalidates cache} { cleanup 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 } {bar} test cgetcache-1.3 {Invalid -cgetmethod causes error} { cleanup type dog { option -foo -default bar -cgetmethod bogus } dog fido -foo quux catch {fido cget -foo} result set result } {can't cget -foo, "::fido bogus" is not defined} test cgetcache-1.3 {hierarchical -cgetmethod} { cleanup type dog { option -foo -default bar -cgetmethod {Get Opt} method {Get Opt} {option} { return Dummy } } dog fido fido cget -foo } {Dummy} #----------------------------------------------------------------------- # Configure cache test configurecache-1.1 {Instance rename invalidates cache} { cleanup 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 } {baz} test configurecache-1.2 {Component rename invalidates cache} { cleanup 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 } {baz} test configurecache-1.3 {Invalid -configuremethod causes error} { cleanup type dog { option -foo -default bar -configuremethod bogus } dog fido catch {fido configure -foo quux} result set result } {can't configure -foo, "::fido bogus" is not defined} test configurecache-1.4 {hierarchical -configuremethod} { cleanup 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 } {Dummy} #----------------------------------------------------------------------- # option -validatemethod test validatemethod-1.1 {Validate method is called} { cleanup 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 } {1} test validatemethod-1.2 {Validate method gets correct arguments} { cleanup type dog { option -color \ -default black \ -validatemethod ValidateColor method ValidateColor {option value} { if {$option ne "-color" || $value ne "brown"} { error "Expected '-color brown'" } } } dog fido -color brown } {::fido} test validatemethod-1.3 {Invalid -validatemethod causes error} { cleanup type dog { option -foo -default bar -validatemethod bogus } dog fido catch {fido configure -foo quux} result set result } {can't validate -foo, "::fido bogus" is not defined} test validatemethod-1.4 {hierarchical -validatemethod} { cleanup type dog { option -foo -default bar -validatemethod {Val Opt} method {Val Opt} {option value} { error "Dummy" } } catch {dog fido -foo value} result set result } {Error in constructor: Dummy} #----------------------------------------------------------------------- # option -readonly semantics test optionreadonly-1.1 {Readonly options can be set at creation time} { cleanup type dog { option -color \ -default black \ -readonly true } dog fido -color brown fido cget -color } {brown} test optionreadonly-1.2 {Readonly options can't be set after creation} { cleanup type dog { option -color \ -default black \ -readonly true } dog fido catch { fido configure -color brown } result set result } {option -color can only be set at instance creation} test optionreadonly-1.3 {Readonly options can't be set after creation} { cleanup type dog { option -color \ -default black \ -readonly true } dog fido -color yellow catch { fido configure -color brown } result set result } {option -color can only be set at instance creation} #----------------------------------------------------------------------- # Pragma -hastypeinfo test hastypeinfo-1.1 {$type info is defined by default} { cleanup type dog { typevariable foo } dog info typevars } {::dog::foo} test hastypeinfo-1.2 {$type info can be disabled} { cleanup type dog { pragma -hastypeinfo no typevariable foo } catch { dog info typevars } result set result } {"::dog info" is not defined} #----------------------------------------------------------------------- # Pragma -hastypedestroy test hastypedestroy-1.1 {$type destroy is defined by default} { cleanup type dog { typevariable foo } dog destroy catch { ::dog info typevars } result set result } {invalid command name "::dog"} test hastypedestroy-1.2 {$type destroy can be disabled} { cleanup type dog { pragma -hastypedestroy no typevariable foo } catch { dog destroy } result # If we don't delete the type explicitly, "cleanup" will # fail in the next test. namespace delete ::dog rename ::dog "" set result } {"::dog destroy" is not defined} #----------------------------------------------------------------------- # Pragma -hasinstances test hasinstances-1.1 {-hasinstances is true by default} { cleanup catch { type dog { method bark {} { return "Woof" } } dog fido fido bark } result set result } {Woof} test hasinstances-1.2 {'-hasinstances no' disables explicit object creation} { cleanup type dog { pragma -hasinstances no } catch { dog create fido } result set result } {"::dog create" is not defined} test hasinstances-1.3 {'-hasinstances no' disables implicit object creation} { cleanup type dog { pragma -hasinstances no } catch { dog fido } result set result } {"::dog fido" is not defined} #----------------------------------------------------------------------- # pragma -canreplace test canreplace-1.1 {By default, "-canreplace no"} { cleanup type dog { # ... } catch { dog fido dog fido } result set result } {command "::fido" already exists} test canreplace-1.2 {Can replace commands when "-canreplace yes"} { cleanup type dog { pragma -canreplace yes } dog fido dog fido } {::fido} #----------------------------------------------------------------------- # pragma -hasinfo test hasinfo-1.1 {$obj info is defined by default} { cleanup type dog { variable foo } dog spot spot info vars } {::dog::Snit_inst1::foo} test hasinfo-1.2 {$obj info can be disabled} { cleanup type dog { pragma -hasinfo no variable foo } catch { dog spot spot info vars } result set result } {"::spot info" is not defined} #----------------------------------------------------------------------- # 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.} { cleanup type dog { pragma -hastypemethods no variable foo } set res [dog spot] # Create a new type dog that has a destroy typemethod, so the # cleanup works. type dog { variable foo } set res } {::spot} test hastypemethods-1.2 {-hastypemethods no, $type create foo fails.} { catch {cleanup} type dog { pragma -hastypemethods no variable foo } catch {dog create spot} result # Create a new type dog that has a destroy typemethod, so the # cleanup works. type dog { variable foo } set result } {Error in constructor: wrong # args: should be "::dog::Snit_constructor type selfns win self"} test hastypemethods-1.3 {-hastypemethods no, $type info fails.} { catch {cleanup} type dog { pragma -hastypemethods no variable foo } catch {dog info} result # Create a new type dog that has a destroy typemethod, so the # cleanup works. type dog { variable foo } set result } {command "::info" already exists} test hastypemethods-1.4 {-hastypemethods no, [$widget] fails.} tk { catch {cleanup} widget dog { pragma -hastypemethods no variable foo } catch {dog} result # Create a new type dog that has a destroy typemethod, so the # cleanup works. widget dog { variable foo } set result } {wrong # args: should be "::dog name args"} test hastypemethods-1.5 {-hastypemethods no, -hasinstances no fails.} { catch {cleanup} catch { type dog { pragma -hastypemethods no pragma -hasinstances no variable foo } } result set result } {type ::dog has neither typemethods nor instances} #----------------------------------------------------------------------- # -simpledispatch yes test simpledispatch-1.1 {not allowed with method delegation.} { catch {cleanup} catch { type dog { pragma -simpledispatch yes delegate method foo to bar } } result set result } {type ::dog requests -simpledispatch but delegates methods.} test simpledispatch-1.2 {normal methods work with simpledispatch.} { catch {cleanup} type dog { pragma -simpledispatch yes method barks {how} { return "$self barks $how." } } dog spot spot barks loudly } {::spot barks loudly.} test simpledispatch-1.3 {option methods work with simpledispatch.} { catch {cleanup} 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 } {mutt collie sheltie} test simpledispatch-1.4 {info method works with simpledispatch.} { catch {cleanup} type dog { pragma -simpledispatch yes option -breed mutt } dog spot spot info options } {-breed} test simpledispatch-1.5 {destroy method works with simpledispatch.} { catch {cleanup} 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 } {::spot {}} test simpledispatch-1.6 {no hierarchical methods with simpledispatch.} { catch {cleanup} catch { type dog { pragma -simpledispatch yes method {wag tail} {} {} } } result set result } {type ::dog requests -simpledispatch but defines hierarchical methods.} #----------------------------------------------------------------------- # Exotic return codes test break-1.1 {Methods can "return -code break"} { cleanup snit::type dog { method bark {} {return -code break "Breaking"} } dog spot catch {spot bark} result } {3} test break-1.2 {Typemethods can "return -code break"} { cleanup snit::type dog { typemethod bark {} {return -code break "Breaking"} } catch {dog bark} result } {3} test break-1.3 {Methods called via mymethod "return -code break"} { cleanup snit::type dog { method bark {} {return -code break "Breaking"} method getbark {} { return [mymethod bark] } } dog spot catch {uplevel \#0 [spot getbark]} result } {3} #----------------------------------------------------------------------- # Bug Fixes test bug-1.1 {Bug 1161779: destructor can't precede constructor} \ -cleanup {rename ::dummy ""} \ -body { type dummy { destructor { # No content } constructor {args} { $self configurelist $args } } } -result ::dummy test bug-2.1 {Bug 1106375: Widget Error on failed object's construction} \ -cleanup {::mylabel destroy} \ -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 } -result {{} {Error in constructor: simulated error}} test bug-2.2 {Bug 1106375: Widget Error on failed object's construction} \ -cleanup {::myframe destroy} \ -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 } -result {{} {Error in constructor: simulated error}} #--------------------------------------------------------------------- # Clean up ::tcltest::cleanupTests tcltk2/inst/tklibs/snit1.0/roadmap.txt0000644000176000001440000001414512215417550017341 0ustar ripleyusersThis 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/snit1.0/README.txt0000644000176000001440000006731012215417550016655 0ustar ripleyusersSnit'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). 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/snit1.0/snit.html0000644000176000001440000030544612215417550017027 0ustar ripleyusers snit - Snit's Not Incr Tcl, OO system

snit(n) 1.0 snit "Snit's Not Incr Tcl, OO system"

NAME

snit - Snit's Not Incr Tcl

TABLE OF CONTENTS

    TABLE OF CONTENTS
    SYNOPSIS
    DESCRIPTION
    REFERENCE
        Type and Widget Definitions
        The Type Command
        Standard Type Methods
        The Instance Command
        Standard Instance Methods
        Commands for use in Object Code
        Components and Delegation
        Type Components and Delegation
        The Tk Option Database
        Macros and Meta-programming
    CAVEATS
    KNOWN BUGS
    HISTORY
    CREDITS
    KEYWORDS
    COPYRIGHT

SYNOPSIS

package require Tcl 8.4
package require snit ?1.0?

snit::type name definition
typevariable name ?-array? ?value?
typemethod name arglist body
typeconstructor body
variable name ?-array? ?value?
method name arglist body
option namespec ?defaultValue?
option namespec ?options...?
constructor arglist body
destructor body
proc name args body
delegate method name to comp ?as target?
delegate method name ?to comp? using pattern
delegate method * ?to comp? ?using pattern? ?except exceptions?
delegate option namespec to comp
delegate option namespec to comp as target
delegate option * to comp
delegate option * to comp except exceptions
component comp ?-public method? ?-inherit flag?
delegate typemethod name to comp ?as target?
delegate typemethod name ?to comp? using pattern
delegate typemethod * ?to comp? ?using pattern? ?except exceptions?
typecomponent comp ?-public typemethod? ?-inherit flag?
pragma ?options...?
expose comp
expose comp as method
onconfigure name arglist body
oncget name body
snit::widget name definition
widgetclass name
hulltype type
snit::widgetadaptor name definition
snit::typemethod type name arglist body
snit::method type name arglist body
snit::macro name arglist body
snit::compile which type body
$type typemethod args...
$type create name ?option value ...?
$type info typevars ?pattern?
$type info typemethods ?pattern?
$type info instances ?pattern?
$type destroy
$object method args...
$object configure ?option? ?value? ...
$object configurelist optionlist
$object cget option
$object destroy
$object info type
$object info vars ?pattern?
$object info typevars ?pattern?
$object info typemethods ?pattern?
$object info options ?pattern?
$object info methods ?pattern?
mymethod name ?args...?
mytypemethod name ?args...?
myproc name ?args...?
myvar name
mytypevar name
from argvName option ?defvalue?
install compName using objType objName args...
installhull using widgetType args...
installhull name
variable name
typevariable name
varname name
typevarname name
codename name

DESCRIPTION

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 Tk widget, an Incr Tcl object, a BWidget or almost anything else.

This man page is intended to be a reference only; see the accompanying snitfaq for a gentler, more tutorial introduction to Snit concepts.

REFERENCE

Type and Widget Definitions

Snit provides the following commands for defining new types:

snit::type name definition
Defines a new abstract data type called name. If name is not a fully qualified command name, it is assumed to be a name in the namespace in which the snit::type command was called (usually the global namespace). It returns the fully qualified name of the new type.

The type name is then a command that is used to create objects of the new type, along with other activities.

The snit::type definition block is a script that may contain the following definitions:

typevariable name ?-array? ?value?
Defines a type variable with the specified name, and optionally the specified value. Type variables are shared by all instances of the type. If the -array option is included, then value should be a list of keyword/value pairs; it will be assigned to the variable in the manner of array set.

typemethod name arglist body
Defines a type method, a subcommand of the new type command, with the specified name, argument list, and body. The arglist is a normal Tcl argument list and may contain default arguments and the args argument; however, it may not contain the argument names type, self, selfns, or win.

The variable type is automatically defined in the body to the type's fully-qualified name. In addition, type variables are automatically visible in the body of every type method.

If the name consists of two or more tokens, Snit handles it specially:

 
    typemethod {a b} {} { ... }

The following two calls to this type method are equivalent:

 
    $type {a b}
    $type a b

In other words, a becomes a subcommand of $type, and b becomes a subcommand of a. This makes it possible to define a hierarchical command structure; see method, below, for more examples.

typeconstructor body
The type constructor's 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 The Tk Option Database.

The variable type is automatically defined in the body, and contains the type's fully-qualified name. In addition, type variables are automatically visible in the body of the type constructor.

A type may define at most one type constructor.

variable name ?-array? ?value?
Defines an instance variable, a private variable associated with each instance of this type, and optionally its initial value. If the -array option is included, then value should be a list of keyword/value pairs; it will be assigned to the variable in the manner of array set.

method name arglist body
Defines an instance method, a subcommand of each instance of this type, with the specified name, argument list and body. The arglist is a normal Tcl argument list and may contain default arguments and the args argument.

The method is implicitly passed the following arguments as well: type, which contains the fully-qualified type name; self, which contains the current instance command name; selfns, which contains the name of the instance's private namespace; and win, which contains the original instance name. Consequently, the arglist may not contain the argument names type, self, selfns, or win.

An instance method defined in this way is said to be locally defined.

Type and instance variables are automatically visible in all instance methods. If the type has locally defined options, the options array is also visible.

If the name consists of two or more tokens, Snit handles it specially:

 
    method {a b} {} { ... }

The following two calls to this type method are equivalent:

 
    $self {a b}
    $self a b

In other words, a becomes a subcommand of $self, and b becomes a subcommand of a. This makes it possible to define a hierarchical command structure. For 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.

option namespec ?defaultValue?
option namespec ?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 defaultValue is specified.

An option defined in this way is said to be locally defined.

The namespec is a list defining the option's name, resource name, and class name, e.g.:

 
    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:

 
    option -font {Courier 12}

See The Tk Option Database for more information about resource and class names.

Options are normally set and retrieved using the standard instance methods configure and cget; within instance code (method bodies, etc.), option values are available through the options array:

 
    set myfont $options(-font)

If the type defines any option handlers (e.g., -configuremethod), then it should probably use configure and cget to access its options to avoid subtle errors.

The option statement may include the following options:

-default defvalue
Defines the option's default value; the option's default value will be "" otherwise.

-readonly flag
The flag can be any Boolean value recognized by Tcl. If flag is true, then the option is readonly--it can only be set using configure or configurelist at creation time, i.e., in the type's constructor.

-cgetmethod methodName
Every locally-defined option may define a -cgetmethod; it is called when the option's value is retrieved using the cget method. Whatever the method's body returns will be the return value of the call to cget.

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 cget:

 
    option -font -cgetmethod GetOption
    method GetOption {option} {
        return $options($option)
    }

Note that it's possible for any number of options to share a -cgetmethod.

-configuremethod methodName
Every locally-defined option may define a -configuremethod; it is called when the option's value is set using the configure or 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 options() array unless the method saves it there.

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 configure:

 
    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 -configuremethod.

-validatemethod methodName
Every locally-defined option may define a -validatemethod; it is called when the option's value is set using the configure or configurelist methods, just before the -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.

The named method must take two arguments, the option name and its new value. For example, this code verifies that -flag's value is a valid Boolean value:

 
    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 -validatemethod.
constructor arglist body
The constructor definition specifies a body of code to be executed when a new instance is created. The arglist is a normal Tcl argument list and may contain default arguments and the args argument.

As with methods, the arguments type, self, selfns, and win are defined implicitly, and all type and instance variables are automatically visible in its body.

If the 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:

 
    constructor {args} {
        $self configurelist $args
    }

For standard Tk widget behavior, the argument list should be the single name args, as shown.

If the definition defines neither a constructor nor any options, the default constructor is defined as follows:

 
    constructor {} {}



destructor 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.

The destructor takes no explicit arguments; as with methods, the arguments type, self, selfns, and win, are defined implicitly, and all type and instance variables are automatically visible in its body.

proc name args body
Defines a new Tcl procedure in the type's namespace.

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 selfns (with precisely that name) as one of its arguments.

Although they are not implicitly defined for procs, the argument names type, self, and win should be avoided.

delegate method name to comp ?as target?
Delegates method name to component comp. That is, when method 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

 
    delegate method wag to tail

is roughly equivalent to this explicitly defined method:

 
    method wag {args} {
        uplevel $tail wag $args
    }

As with methods, the 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.

The optional as clause allows you to specify the delegated method name and possibly add some arguments:

 
    delegate method wagtail to tail as "wag briskly"



A method cannot be both locally defined and delegated.

Note: All forms of delegate method can delegate to both instance components and type components.

delegate method name ?to comp? using pattern
In this form of the delegate statement, the using clause is used to specify the precise form of the command to which method name name is delegated. In this form, the to clause is optional, since the chosen command might not involve any particular component.

The value of the 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:

 
    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.

Substitutions:

%%
This is replaced with a single "%". Thus, to pass the string "%c" to the command as an argument, you'd write "%%c".

%c
This is replaced with the named component's command.

%m
This is replaced with the final token of the method name; if the method name has one token, this is identical to %M.

%M
This is replaced by the method name; if the name consists of multiple tokens, they are joined by space characters.

%j
This is replaced by the method name; if the name consists of multiple tokens, they are joined by underscores ("_").

%t
This is replaced with the fully qualified type name.

%n
This is replaced with the name of the instance's private namespace.

%s
This is replaced with the name of the instance command.

%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.
delegate method * ?to comp? ?using pattern? ?except exceptions?
The form delegate method * delegates all unknown method names to the specified component. The except clause can be used to specify a list of exceptions, i.e., method names that will not be so delegated. The using clause is defined as given above. In this form, the statement must contain the to clause, the using clause, or both.

In fact, the "*" can be a list of two or more tokens whose last element is "*", as in the following example:

 
    delegate method {tail *} to tail

This implicitly defines the method tail whose subcommands will be delegated to the tail component.

delegate option namespec to comp
delegate option namespec to comp as target
delegate option * to comp
delegate option * to comp except exceptions
Defines a delegated option; the namespec is defined as for the option statement. When the configure, configurelist, or cget instance method is used to set or retrieve the option's value, the equivalent configure or cget command will be applied to the component as though these onconfigure and oncget handlers were defined, where name is the option name from the namespec:

 
    onconfigure name {value} {
        $comp configure name $value
    }

    oncget name {
        return [$comp cget name]
    }

If the as clause is specified, then the target option name is used in place of name.

The form delegate option * delegates all unknown method names to the specified component. The except clause can be used to specify a list of exceptions, i.e., option names that will not be so delegated.

Warning: options can only be delegated to a component if it supports the configure and cget instance methods.

Note that an option cannot be both locally defined and delegated.

component comp ?-public method? ?-inherit flag?
Explicitly declares a component called comp, and automatically defines the component's instance variable.

If the -public option is specified, then the option is made public by defining a method whose subcommands are delegated to the component e.g., specifying -public mycomp is equivalent to the following:

 
    component mycomp
    delegate method {mymethod *} to mycomp

If the -inherit option is specified, then flag must be a Boolean value; if flag is true then all unknown methods and options will be delegated to this component. The name -inherit implies that instances of this new type inherit, in a sense, the methods and options of the component. That is, -inherit yes is equivalent to:

 
    component mycomp
    delegate option * to mycomp
    delegate method * to mycomp



delegate typemethod name to comp ?as target?
Delegates type method name to type component comp. That is, when type method 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

 
    delegate typemethod lostdogs to pound

is roughly equivalent to this explicitly defined method:

 
    typemethod lostdogs {args} {
        uplevel $pound lostdogs $args
    }

As with type methods, the 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.

The optional as clause allows you to specify the delegated method name and possibly add some arguments:

 
    delegate typemethod lostdogs to pound as "get lostdogs"



A type method cannot be both locally defined and delegated.

delegate typemethod name ?to comp? using pattern
In this form of the delegate statement, the using clause is used to specify the precise form of the command to which type method name name is delegated. In this form, the to clause is optional, since the chosen command might not involve any particular type component.

The value of the 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:

 
    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.

Substitutions:

%%
This is replaced with a single "%". Thus, to pass the string "%c" to the command as an argument, you'd write "%%c".

%c
This is replaced with the named type component's command.

%m
This is replaced with the final token of the type method name; if the type method name has one token, this is identical to %M.

%M
This is replaced by the type method name; if the name consists of multiple tokens, they are joined by space characters.

%j
This is replaced by the type method name; if the name consists of multiple tokens, they are joined by underscores ("_").

%t
This is replaced with the fully qualified type name.
delegate typemethod * ?to comp? ?using pattern? ?except exceptions?
The form delegate typemethod * delegates all unknown type method names to the specified type component. The except clause can be used to specify a list of exceptions, i.e., type method names that will not be so delegated. The using clause is defined as given above. In this form, the statement must contain the to clause, the using clause, or both.

Note: By default, Snit interprets $type foo, where foo is not a defined type method, as equivalent to $type create foo, where foo is the name of a new instance of the type. If you use delegate typemethod *, then the create type method must always be used explicitly.

The "*" can be a list of two or more tokens whose last element is "*", as in the following example:

 
    delegate typemethod {tail *} to tail

This implicitly defines the type method tail whose subcommands will be delegated to the tail type component.

typecomponent comp ?-public typemethod? ?-inherit flag?
Explicitly declares a type component called 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.

If the -public option is specified, then the type component is made public by defining a typemethod whose subcommands are delegated to the type component, e.g., specifying -public mytypemethod is equivalent to the following:

 
    typecomponent mycomp
    delegate typemethod {mytypemethod *} to mycomp

If the -inherit option is specified, then flag must be a Boolean value; if flag is true then all unknown type methods will be delegated to this type component. (See the note on "delegate typemethod *", above.) The name -inherit implies that this type inherits, in a sense, the behavior of the type component. That is, -inherit yes is equivalent to:

 
    typecomponent mycomp
    delegate typemethod * to mycomp



pragma ?options...?
The pragma statement provides control over how Snit generates a type. It takes the following options; in each case, flag must be a Boolean value recognized by Tcl, e.g., 0, 1, yes, no, and so on.

By setting the -hastypeinfo, -hastypedestroy, and -hasinstances pragmas to false and defining appropriate type methods, you can create an ensemble command without any extraneous behavior.

-canreplace flag
If false (the default) Snit will not create an instance of a 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.

-hastypeinfo flag
If true (the default), the generated type will have a type method called info that is used for type introspection; the info type method is documented below. If false, it will not.

-hastypedestroy flag
If true (the default), the generated type will have a type method called destroy that is used to destroy the type and all of its instances. The destroy type method is documented below. If false, it will not.

-hastypemethods 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.

This pragma and -hasinstances cannot both be set false.

-hasinstances flag
If true (the default), the generated type will have a type method called create that is used to create instances of the type, along with a variety of instance-related features. If false, it will not.

This pragma and -hastypemethods cannot both be set false.

-hasinfo flag
If true (the default), instances of the generated type will have an instance method called info that is used for instance introspection; the info method is documented below. If false, it will not.

-simpledispatch flag
This pragma is intended to make simple, heavily-used abstract data types (e.g., stacks and queues) more efficient.

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 -simpledispatch yes you get the following limitations:

  • Methods cannot be delegated.

  • uplevel and upvar do not work as expected: the caller's scope is two levels up rather than one.

  • The option-handling methods (cget, configure, and configurelist) are very slightly slower.
expose comp
expose comp as method
Deprecated. To expose component comp publicly, use component's -public option.

onconfigure name arglist body
Deprecated. Define option's -configuremethod option instead.

As of version 0.95, the following definitions,

 
    option -myoption
    onconfigure -myoption {value} {
        # Code to save the option's value
    }

are implemented as follows:

 
    option -myoption -configuremethod _configure-myoption
    method _configure-myoption {_option value} {
        # Code to save the option's value
    }



oncget name body
Deprecated. Define option's -cgetmethod option instead.

As of version 0.95, the following definitions,

 
    option -myoption
    oncget -myoption {
        # Code to return the option's value
    }

are implemented as follows:

 
    option -myoption -cgetmethod _cget-myoption
    method _cget-myoption {_option} {
        # Code to return the option's value
    }

snit::widget name definition
This command defines a Snit megawidget type with the specified name. The definition is defined as for snit::type. A snit::widget differs from a snit::type in these ways:

  • Every instance of a snit::widget has an automatically-created component called hull, which is normally a Tk frame widget. Other widgets created as part of the megawidget will be created within this widget.

    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 hull.

  • The name of an instance must be valid Tk window name, and the parent window must exist.
A snit::widget definition can include any of statements allowed in a snit::type definition, and may also include the following:

widgetclass name
Sets the snit::widget's widget class to name, overriding the default. See The Tk Option Database for more information.

hulltype type
Determines the kind of widget used as the snit::widget's hull. The type may be frame (the default) or toplevel.
snit::widgetadaptor name definition
This command defines a Snit megawidget type with the specified name. It differs from snit::widget in that the instance's hull component is not created automatically, but is created in the constructor and installed using the installhull command. Once the hull is installed, its instance command is renamed and replaced as with normal snit::widgets. The original command is again accessible in the instance variable hull.

Note that in general it is not possible to change the widget class of a snit::widgetadaptor's hull widget.

See The Tk Option Database for information on how snit::widgetadaptors interact with the option database.

snit::typemethod type name arglist body
Defines a new type method (or redefines an existing type method) for a previously existing type.

snit::method type name arglist body
Defines a new instance method (or redefines an existing instance method) for a previously existing type. Note that delegated instance methods can't be redefined.

snit::macro name arglist body
Defines a Snit macro with the specified name, arglist, and body. Macros are used to define new type and widget definition statements in terms of the statements defined in this man page.

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 Macros and Meta-programming for more details.

The macro 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 method or delegate statements, or the standard set, list, or string commands.

snit::compile which type 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.

This command exposes the "compiler". Given a definition body for the named type, where which is type, widget, or widgetadaptor, snit::compile returns a list of two elements. The first element is the fully qualified type name; the second element is the definition script.

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.

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:

$type typemethod args...
The typemethod can be any of the Standard Type Methods (e.g., create), or any type method defined in the type definition. The subsequent args depend on the specific typemethod chosen.

The type command is most often used to create new instances of the type; hence, the create method is assumed if the first argument to the type command doesn't name a valid type method, unless the type definition includes delegate typemethod * or the -hasinstances pragma is set to false.

Furthermore, 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 type has instances, the following commands are equivalent:

 
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.

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:

$type create name ?option value ...?
Creates a new instance of the type, giving it the specified name and calling the type's constructor.

For snit::types, if name is not a fully-qualified command name, it is assumed to be a name in the namespace in which the call to snit::type appears. The method returns the fully-qualified instance name.

For snit::widgets and snit::widgetadaptors, name must be a valid widget name; the method returns the widget name.

So long as name does not conflict with any defined type method name the create keyword may be omitted, unless the type definition includes delegate typemethod * or the -hasinstances pragma is set to false.

If the name includes the string %AUTO%, it will be replaced with the string $type$counter where $type is the type name and $counter is a counter that increments each time %AUTO% is used for this type.

By default, any arguments following the name will be a list of option names and their values; however, a type's constructor can specify a different argument list.

As of Snit V0.95, create will throw an error if the name is the same as any existing command--note that this was always true for snit::widgets and snit::widgetadaptors. You can restore the previous behavior using the -canreplace pragma.

$type info typevars ?pattern?
Returns a list of the type's type variables (excluding Snit internal variables); all variable names are fully-qualified.

If pattern is given, it's used as a string match pattern; only names that match the pattern are returned.

$type info typemethods ?pattern?
Returns a list of the names of the type's type methods. If the type definition includes 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.

If pattern is given, it's used as a string match pattern; only names that match the pattern are returned.

$type info instances ?pattern?
Returns a list of the type's instances. For snit::types, it will be a list of fully-qualified instance names; for snit::widgets, it will be a list of Tk widget names.

If pattern is given, it's used as a string match pattern; only names that match the pattern are returned.

$type destroy
Destroys the type's instances, the type's namespace, and the type command itself.

The Instance Command

A Snit type or widget's 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:

$object method args...
The method can be any of the Standard Instance Methods, or any instance method defined in the type definition. The subsequent args depend on the specific method chosen.

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:

$object configure ?option? ?value? ...
Assigns new values to one or more options. If called with one argument, an 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.

Warning: This information will be available for delegated options only if the component to which they are delegated has a configure method that returns this same kind of information.

Note: Snit defines this method only if the type has at least one option.

$object configurelist optionlist
Like 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.

Note: Snit defines this method only if the type has at least one option.

$object cget option
Returns the option's value.

Note: Snit defines this method only if the type has at least one option.

$object destroy
Destroys the object, calling the destructor and freeing all related memory.

Note: The destroy method isn't defined for snit::widget or snit::widgetadaptor objects; instances of these are destroyed by calling Tk's destroy command, just as normal widgets are.

$object info type
Returns the instance's type.

$object info vars ?pattern?
Returns a list of the object's instance variables (excluding Snit internal variables). The names are fully qualified.

If pattern is given, it's used as a string match pattern; only names that match the pattern are returned.

$object info typevars ?pattern?
Returns a list of the object's type's type variables (excluding Snit internal variables). The names are fully qualified.

If pattern is given, it's used as a string match pattern; only names that match the pattern are returned.

$object info typemethods ?pattern?
Returns a list of the names of the instance's type's type methods. If the type definition includes 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.

If pattern is given, it's used as a string match pattern; only names that match the pattern are returned.

$object info options ?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 $object configure like Tk widgets do, then the result will include all possible unknown options that can be delegated to the component.

If pattern is given, it's used as a string match pattern; only names that match the pattern are returned.

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.

$object info methods ?pattern?
Returns a list of the names of the instance's methods. If the type definition includes 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.

If pattern is given, it's used as a string match pattern; only names that match the pattern are returned.

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.

mymethod name ?args...?
The mymethod command is used for formatting callback commands to be passed to other objects. It returns a command that when called will invoke method 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 dosomething method to be called when the $button is pressed:

 
    $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.

mytypemethod name ?args...?
The 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 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 dosomething type method to be called when $button is pressed:

 
    $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. mytypemethod is provided for parallelism with mymethod.

myproc name ?args...?
The 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 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 dosomething proc to be called when $button is pressed:

 
    $button configure -command [list ${type}::dosomething myargument]
       
    $button configure -command [myproc dosomething myargument]



myvar 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 -textvariable to a Tk label widget.

mytypevar 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 -textvariable to a Tk label widget.

from argvName option ?defvalue?
The from command plucks an option value from a list of options and their values, such as is passed into a type's constructor. argvName must be the name of a variable containing such a list; option is the name of the specific option.

from looks for option in the option list. If it is found, it and its value are removed from the list, and the value is returned. If option doesn't appear in the list, then the defvalue is returned. If the option is locally-defined option, and defvalue is not specified, then the option's default value as specified in the type definition will be returned instead.

install compName using objType objName args...
Creates a new object of type objType called objName and installs it as component compName, as described in Components and Delegation. Any additional args... are passed along with the name to the objType command. If this is a snit::type, then the following two commands are equivalent:

 
    install myComp using myObjType $self.myComp args...

    set myComp [myObjType $self.myComp args...]

Note that whichever method is used, compName must still be declared in the type definition using component, or must be referenced in at least one delegate statement.

If this is a snit::widget or snit::widgetadaptor, and if options have been delegated to component 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 The Tk Option Database for more information.

install cannot be used to install type components; just assign the type component's command name to the type component's variable instead.

installhull using widgetType args...
installhull name
The constructor of a 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 $win. This command has two forms.

The first form specifies the widgetType and the args... (that is, the hardcoded option list) to use in creating the hull. Given this form, installhull creates the hull widget, and initializes any options delegated to the hull from the Tk option database.

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 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 BWidgets tabbed notebook or pages manager widget.

See The Tk Option Database for more information about snit::widgetadaptors and the option database.

variable 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 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.

It's generally clearest to define all instance variables in the type definition, and omit declaring them in methods and so forth.

Note that this is an instance-specific version of the standard Tcl ::variable command.

typevariable 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 typevariable to declare type variables that don't appear in the type definition.

It's generally clearest to declare all type variables in the type definition, and omit declaring them in methods, type methods, etc.

varname name
Deprecated. Use myvar instead.

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 -textvariable to a Tk label widget.

typevarname name
Deprecated. Use mytypevar instead.

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 -textvariable to a Tk label widget.

codename name
Deprecated. Use 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.

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 component, which creates a component instance variable. In the following example, a dog object has a tail object:

 
    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."}
    }

Because the tail object's name is stored in an instance variable, it's easily accessible in any method.

The install command provides an alternate way to create and install the component:

 
    snit::type dog {
        component mytail

        constructor {args} {
            install mytail using tail %AUTO% -partof $self
            $self configurelist $args
        }

        method wag {} {
            $mytail wag
        }
    }

For snit::types, the two methods are equivalent; for snit::widgets and snit::widgetadaptors, the install command properly initializes the widget's options by querying The Tk Option Database.

In the above examples, the dog object's wag method simply calls the tail component's wag method. In OO jargon, this is called delegation. Snit provides an easier way to do this:

 
    snit::type dog {
        delegate method wag to mytail
    
        constructor {args} {
            install mytail using tail %AUTO% -partof $self
            $self configurelist $args
        }
    }

The delegate statement in the type definition implicitly defines the instance variable mytail to hold the component's name (though it's good form to use component to declare it explicitly); it also defines the dog object's wag method, delegating it to the mytail component.

If desired, all otherwise unknown methods can be delegated to a specific component:

 
    snit::type dog {
	delegate method * to mytail

	constructor {args} {
	    set mytail [tail %AUTO% -partof $self]
	    $self configurelist $args
	}

	method bark { return "Bark, bark, bark!" }
    }

In this case, a dog object will handle its own bark method; but wag will be passed along to mytail. Any other method, being recognized by neither dog nor tail, will simply raise an error.

Option delegation is similar to method delegation, except for the interactions with the Tk option database; this is described in The Tk Option Database.

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.

Just as delegate method can be used to delegate methods to instance components, as described in Components and Delegation, so delegate typemethod can be used to delegate type methods to type components.

Note also that as of Snit 0.95 delegate method can delegate methods to both instance components and type components.

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 Practical Programming in Tcl and Tk by Welch et al has a good introduction to the option database, as does Effective Tcl/Tk Programming.

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.

  • If the snit::widget's default widget class is not what is desired, set it explicitly using widgetclass in the widget definition.

  • When defining or delegating options, specify the resource and class names explicitly when if the defaults aren't what you want.

  • Use installhull using to install the hull for snit::widgetadaptors.

  • Use install to install all other components.

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.

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 button widgets is "Button".

Similarly, the widget class of a snit::widget defaults to the unqualified type name with the first letter capitalized. For example, the widget class of

 
    snit::widget ::mylibrary::scrolledText { ... }

is "ScrolledText". The widget class can also be set explicitly using the widgetclass statement within the snit::widget definition.

Note that only frame and toplevel widgets allow the user to change the widget class name, which is why they are the only allowable hull types for snit::widgets.

The widget class of a snit::widgetadaptor is just the widget class of its hull widget; this cannot be changed unless the hull widget is a frame or toplevel, in which case it will usually make more sense to use snit::widget rather than snit::widgetadaptor.

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 configure and cget commands.

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 text widget options:

 
    -background         background         Background 
    -borderwidth        borderWidth        BorderWidth 
    -insertborderwidth  insertBorderWidth  BorderWidth 
    -padx               padX               Pad

As is easily seen, sometimes the resource and class names can be inferred from the option name, but not always.

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:

 
    snit::widget mywidget {
        option -background
        delegate option -borderwidth to hull
        delegate option * to text
	# ...
    }

In this case, the widget class name is "Mywidget". The widget has the following options: -background, which is locally defined, and -borderwidth, which is explicitly delegated; all other widgets are delegated to a component called "text", which is probably a Tk text widget. If so, mywidget has all the same options as a text widget. The option, resource, and class names are as follows:

 
    -background  background  Background
    -borderwidth borderwidth Borderwidth
    -padx        padX        Pad

Note that the locally defined option, -background, happens to have the same three names as the standard Tk -background option; and -pad, which is delegated implicitly to the text component, has the same three names for mywidget as it does for the text widget. -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:

 
    snit::widget mywidget {
	option -background
	delegate option {-borderwidth borderWidth} to hull
	delegate option * to text
	# ...
    }

The class name will default to "BorderWidth", as expected.

Suppose, however, that mywidget also delegated -padx and -pady to the hull. In this case, both the resource name and the class name must be specified explicitly:

 
    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
	# ...
    }

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.

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,

 
    option add *Mywidget.texture pebbled

    snit::widget mywidget {
	option -texture smooth
	# ...
    }

    mywidget .mywidget -texture greasy

Here, -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".

Initializing options delegated to the hull: A 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:

 
    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]

The question is, what are the values of variables A, B, C and D?

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 -relief option is implicitly delegated to the hull, Snit takes no action.

The value of B is "red". The hull will automatically pick up the value "green" for its -background option, just as it picked up the -relief value. However, Snit knows that -hullbackground is mapped to the hull's -background option; hence, it queries the option database for -hullbackground and gets "red" and updates the hull accordingly.

The value of C is also "red", because -background is implicitly delegated to the hull; thus, retrieving it is the same as retrieving -hullbackground. Note that this case is unusual; in practice, -background would probably be explicitly delegated to some other component.

The value of D is "5", but not for the reason you think. Note that as it is defined above, the resource name for -borderwidth defaults to "borderwidth", whereas the option database entry is "borderWidth". As with -relief, the hull picks up its own -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.

For snit::widgetadaptors, 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 snit::widgetadaptor must call installhull in its constructor. The normal way to do this is as follows:

 
    snit::widgetadaptor mywidget {
	# ...
	constructor {args} {
	    # ...
	    installhull using text -foreground white
	    #
	}
	#...
    }

In this case, the installhull command will create the hull using a command like this:

 
    set hull [text $win -foreground white]

The hull is a text widget, so its widget class is "Text". Just as with 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.

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 install command is used to create it.

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:

 
    snit::widget mywidget {
	delegate option -background to myComp

	constructor {args} {
	    set myComp [text $win.text -foreground black]
	}
    }

The drawback of this method is that Snit has no opportunity to initialize the component properly. Hence, the following approach is now used:

 
    snit::widget mywidget {
	delegate option -background to myComp

	constructor {args} {
	    install myComp using text $win.text -foreground black
	}
    }

The install command does the following:

  • Builds a list of the options explicitly included in the install command -- in this case, -foreground.

  • Queries the option database for all options delegated explicitly to the named component.

  • 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 (-foreground) will override anything read from the option database.

  • If the widget definition implicitly delegated options to the component using delegate option *, then Snit calls the newly created component's 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 install command. For all such options, Snit queries the option database and configures the component accordingly.

Non-widget components: The option database is never queried for snit::types, since it can only be queried given a Tk widget name. However, snit::widgets can have non-widget components. And if options are delegated to those components, and if the install command is used to install those components, then they will be initialized from the option database just as widget components are.

Macros and Meta-programming

The 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:

 
    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 snit::macro:

 
    snit::macro property {name initValue} {
        variable $name $initValue

        method get$name {} "return $name"

        method set$name {value} "set $name \$value"
    }

Note that a 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.

Given this new macro, you can define a property in one line of code:

 
    snit::type dog {
        property mood happy
    }

Within a macro, the commands variable and proc refer to the Snit type-definition commands, not the standard Tcl commands. To get the standard Tcl commands, use _variable and _proc.

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 snit::macros, define them in your package namespace:

 
    snit::macro mypkg::property {name initValue} { ... }

    snit::type dog {
        mypkg::property mood happy
    }

This leaves the global namespace open for application authors.

CAVEATS

Please understand that while Snit is well-tested and fairly stable, it is still evolving (we have not yet reached Snit 1.0). If you have problems, find bugs, or new ideas you are hereby cordially invited to submit a report of your problem, bug, or idea at the SourceForge trackers for tcllib, which can be found at http://sourceforge.net/projects/tcllib/. The relevant category is snit.

Additionally, you might wish to join the Snit mailing list; see http://www.wjduquette.com/snit for details.

One particular area to watch is using snit::widgetadaptor to adapt megawidgets created by other megawidget packages; correct widget destruction depends on the order of the <Destroy> bindings. The wisest course is simply not to do this.

KNOWN BUGS

  • Error stack traces returned by Snit are extremely ugly and typically contain far too much information about Snit internals.

  • Also see the SourceForge Trackers at http://sourceforge.net/projects/tcllib/, category snit.

HISTORY

During the course of developing Notebook (See 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 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.

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.

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.

If you have any comments or suggestions (or bug reports!) don't hesitate to send me e-mail at will@wjduquette.com. In addition, there's a Snit mailing list; you can find out more about it at the Snit home page (see http://www.wjduquette.com/snit).

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, and Brian Griffin. If I've forgotten anyone, my apologies; let me know and I'll add your name to the list.

KEYWORDS

BWidget, C++, Incr Tcl, Snit, adaptors, class, mega widget, object, object oriented, type, widget, widget adaptors

COPYRIGHT

Copyright © 2003-2005, by William H. Duquette
tcltk2/inst/tklibs/ttktheme_radiance/0000755000176000001440000000000012445051436017431 5ustar ripleyuserstcltk2/inst/tklibs/ttktheme_radiance/pkgIndex.tcl0000644000176000001440000000062412250314762021706 0ustar ripleyusers# 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.tcl0000644000176000001440000002674212262545612022152 0ustar ripleyusers# 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/radiance/0000755000176000001440000000000012445051436021177 5ustar ripleyuserstcltk2/inst/tklibs/ttktheme_radiance/radiance/sbthumb-vd.gif0000644000176000001440000000051712215417550023742 0ustar ripleyusersGIF87a , t , aR x ho"Y48#Ǻ݋_}v{|y {{% _ac!%LFHLA;tcltk2/inst/tklibs/ttktheme_radiance/radiance/sbthumb-ha.gif0000644000176000001440000000033512215417550023717 0ustar ripleyusersGIF87a , b@]MahXG&#9tmgD`%p(l<FAl # @t:7j]ܦW\!AMظF!@"R))!;tcltk2/inst/tklibs/ttktheme_radiance/radiance/comboarrow-d.gif0000644000176000001440000000060512215417550024260 0ustar ripleyusersGIF87ażƽ¹,@"hAHHgJ]XbdIPA5: Dx2ȗ>~1k}y~a`(5--7((+4+ a,39`&+&`0;6lI!v:)%.#*lce 2' ":' ( pHF%(A;tcltk2/inst/tklibs/ttktheme_radiance/radiance/arrowup-d.gif0000644000176000001440000000055312215417550023607 0ustar ripleyusersGIF87aǾżúƽĻ¹,h"h&q2 T h g:N2zPu />Py_,%(`x`2%&_16,9_y7.}_ " )v kj$3:;kbd 4/<'*/ ) oGF$)A;tcltk2/inst/tklibs/ttktheme_radiance/radiance/button-s.gif0000644000176000001440000000264112215417550023442 0ustar ripleyusersGIF89a~RSTZU[\݄aޅb߆cde݊j؎qڏrn֓zڕvۖwݚޛߜᝃ➄㟅䠆ᣇ츤׾軥꼦·ø꾮뿯¬ĮŴ!Created with GIMP! y,SF*\F=iA3j̸ 7U<'\rϕ b!B3f̩O:yA'B(:8!P;FDCfV_Lji)NC&L1a #Frµj| ]lق]{/[l™Π`'H ӥh)`-` AB@ͳP ›_9d &ر+~ Ty lL9d{%0mX!C'`D]R!!C @A!JR}g@q^hqg|(MW"8D8^(f|J q!Di#E(AF %2@C XP DLDXX#2 Ú0 C 2PDxfYq#p&  ÚZHwJ!8& ,£oְCH}i.DBh*@yc~kmZp%Y YVkP`,J5I tP{v-4@xF!Fo&Q;tcltk2/inst/tklibs/ttktheme_radiance/radiance/scaletrough-h.gif0000644000176000001440000000032112215417550024425 0ustar ripleyusersGIF87a ĻŻżŽ, V%dihl;b%tm1D"pL&DQh:ШSP v4dKnJ $#݉AbAT~GX\-!;tcltk2/inst/tklibs/ttktheme_radiance/radiance/toolbutton-d.gif0000644000176000001440000000126112215417550024316 0ustar ripleyusersGIF87a,E". 2./=<6<% -4)1.;9&2!:7 Bdž+'ц8,( ۆ>53'- 9-D* ( *\p=j0HŊHDѠǏ ?fɓ(S4 0cʜ)P 8nɳ'O@.XJѢPÇӧP>`G 0hʵbpАٳh ha 0FȝK.!DrA+CZ ;tcltk2/inst/tklibs/ttktheme_radiance/radiance/radio-dc.gif0000644000176000001440000000116612215417550023352 0ustar ripleyusersGIF89adĻǾǿȿ!Created with GIMP! ,``W((U`D*_cc_*^`R_XRWYR\]$b) [WNWTVSNVZ L%PJE KMQ&NCKEEI O??  CAOJ<@ B?F/6<>:0";4.59=#, Ђƌ4nACF$R&4Xŋ/V4! ly `#i` (6;<wbd 74= -/4 . pGF(.A;tcltk2/inst/tklibs/ttktheme_radiance/radiance/arrowleft-d.gif0000644000176000001440000000107112215417550024111 0ustar ripleyusersGIF87aƽȾƼúǽĻ¹,-#49 =$89 &/-?>3A . 52A+7%"<);ş:10-Ļ6(Ɵ,*! - - '8>?颤(1Hp1 :d -;tcltk2/inst/tklibs/ttktheme_radiance/radiance/arrowup-n.gif0000644000176000001440000000054412215417550023621 0ustar ripleyusersGIF87azzynnmzyxwwussrzzx,@e8#L LTJrCĩz hn̥`%84m1޻  ^}v^~]/2/]w(({} irt.1^1+,i`b# ".-")#mGF#A;tcltk2/inst/tklibs/ttktheme_radiance/radiance/radio-nc.gif0000644000176000001440000000201312215417550023354 0ustar ripleyusersGIF89ayC-J3K4L6T,V+W*\4]5Z)^5`:a8_1b9`1b7b7b8jOkOb3b3mRnSf7jl>l@m?uEvEvFwGwFwGxGxHxG{OyH|PzJzJzKzJȄhɄh|Nτf|L}N~O~Oφh~O~OSRS؈g؈hWފg_ފh͎tWΏuϏwϑv[[[`]]`ޑr_ݒrݒsaߒs_bccdelllkpqqyxyrwx~|}}ؼؽǹȺɼʼ!Created with GIMP! ,"H 2C@AT*A#G :4H 2ZT%K Qy% 5q⤹K<=T XQG'<\3;H0$M p?ft@D 0 @:L`,:ܨ\ƌb v !FB|!ES>s^, @` :~Z;tcltk2/inst/tklibs/ttktheme_radiance/radiance/combo-rp.gif0000644000176000001440000000124712215417550023406 0ustar ripleyusersGIF87aĻžǾнºĻϼ,Y87;JJA8#O$$O&6MCX';V WDR TJRB UJ% 5JPJ?QJH=PNJ31JIP&T #J8QIRhȱcG%.PAɓ' ˗0cTE8sܹSI@ Jԁ: YʴS;dpիXYdž`Ê[DD Ҫ]V YP0`hC;tcltk2/inst/tklibs/ttktheme_radiance/radiance/scale-va.gif0000644000176000001440000000055712215417550023366 0ustar ripleyusersGIF87a ȿĻžȾúǾ, @Ueqrㅑlg3@IG([ 7ǬzV@XNu=yFzG|~ hzh$"!s " %$vVv}]xoqikNcet{_fgZSNP\G )+&EWA;tcltk2/inst/tklibs/ttktheme_radiance/radiance/toolbutton-a.gif0000644000176000001440000000070512215417550024315 0ustar ripleyusersGIF87a,$`B KdEZ4AX SFzf&VfN,FF,,5!F44F!*!FF" "F) )F F22-$ H &:ÇLtA  Xb .Q'#K ;tcltk2/inst/tklibs/ttktheme_radiance/radiance/scale-hn.gif0000644000176000001440000000055612215417550023364 0ustar ripleyusersGIF87a żļŽü, @HȤҨP\ 2Yج)T x:`āx9 ~м)st*!%*~tt$%$%  ɹ  й'ՓA;tcltk2/inst/tklibs/ttktheme_radiance/radiance/check-nc.gif0000644000176000001440000000116612215417550023343 0ustar ripleyusersGIF89alyC-zD-|G2H1P8Q7P5Q,W=^L[?^B[6aEa@bAc>mPwgqSsTsUtTo=xZp@q?q@rA|]vEwGyLzLyI|P{Lց_}Q|M~OPQQQSVVTYZ[[\Zh]\_`badeΛhΜԛϝknolnmmmnlnpoxqqrtu}{~!Created with GIMP! ,h@BhibDY_`_YC R\A>A[Va^<88;S Xk]3N1//2QgZFK-)). fW H'(MG THL7UeJIӱ%:E?$A?jh@'68@f*.|0bVxАH,`# !(i8CfM ;tcltk2/inst/tklibs/ttktheme_radiance/radiance/tree-p.gif0000644000176000001440000000055312215417550023063 0ustar ripleyusersGIF87a,@"H@PBZOgr pL.oD!pC00x2HP Fx~pdec {K  gi    k}IFA;tcltk2/inst/tklibs/ttktheme_radiance/radiance/check-du.gif0000644000176000001440000000052112215417550023345 0ustar ripleyusersGIF89a"úĻżŽƽƾǾǿ!Created with GIMP! ?,Y@ #(i@.4jy8@tʵBw d3HO`[J؀}`}` [i `X LA;tcltk2/inst/tklibs/ttktheme_radiance/radiance/tree-n.gif0000644000176000001440000000055212215417550023060 0ustar ripleyusersGIF87a,8Ȥӑ̃AZ%1Dh0xL&<K`b "GxǎC F}v|ocdb y ""fh   sIGA;tcltk2/inst/tklibs/ttktheme_radiance/radiance/combo-ra.gif0000644000176000001440000000067212215417550023370 0ustar ripleyusersGIF87a,ŴȤ0\H$EZ)ȁerAx YTzVT|Ng8~#*22 1 ((!'  0+##( PB,  La@ BL& ;tcltk2/inst/tklibs/ttktheme_radiance/radiance/sbthumb-hn.gif0000644000176000001440000000050512215417550023733 0ustar ripleyusersGIF87a , jσ@H`ÙAZ=AbQ xD@Dn@v1Dng|m~zJdxafh  BrIIA;tcltk2/inst/tklibs/ttktheme_radiance/radiance/combo-rn.gif0000644000176000001440000000070412215417550023401 0ustar ripleyusersGIF87aƿ,]Ȥ`L2\ZI`xLyznCL|N i$=>%% $;; <<##: 77"*((&+8)$H`Çi1C2jȑ2`bI$M;tcltk2/inst/tklibs/ttktheme_radiance/radiance/toolbutton-p.gif0000644000176000001440000000126312215417550024334 0ustar ripleyusersGIF87aĻžü»ǾнºĻϼ,_>=A!P!G&U'U)%,u J@3"Y 5^8@Qƌ#Fb_"fƏ<0&sg \| ;tcltk2/inst/tklibs/ttktheme_radiance/radiance/comboarrow-p.gif0000644000176000001440000000057512215417550024302 0ustar ripleyusersGIF87anmkjig̎ĕttq״{ywzyvusqrqn,F#`C,fJV`訄rTBxxD× M }-1`}y~B  B$(($B/&&/`'"'B)l%|I#vJ-- +!kce.-  gxHIA;tcltk2/inst/tklibs/ttktheme_radiance/radiance/arrowright-n.gif0000644000176000001440000000054212215417550024310 0ustar ripleyusersGIF87azzynnmwwuzyyssr,WE@#T$HT*j}Diz (oJ ,K]a 5ix)Fy^]xz&1/]z|~ ^rtv-0hj/0*+`b! -, (!nGF!A;tcltk2/inst/tklibs/ttktheme_radiance/radiance/button-n.gif0000644000176000001440000000134612215417550023436 0ustar ripleyusersGIF87aƿ,C1%,"D42! #5*: 3(BB(&BBC'C &&@ A28&pǂ#JP3jܸ1! BIC$\ɲeK\IM. x!ϟ@@G H*]ŅFlJթ9RH ;*K7XlC%X;tcltk2/inst/tklibs/ttktheme_radiance/radiance/sbthumb-vp.gif0000644000176000001440000000051212215417550023751 0ustar ripleyusersGIF87a , oσ g!Ld:C$~B%1xϖ!ួc}ftyzw~yo`b  BFHA;tcltk2/inst/tklibs/ttktheme_radiance/radiance/toolbutton-pa.gif0000644000176000001440000000125312215417550024474 0ustar ripleyusersGIF87a,M&AH-!N@ &M&O$@ M ;>H4> 9"):)'5B21, ? @@<= H0$*\Ȱƒ8H 3j1 CIɑ (˗0[0͛8s P@ J4hC2(]ʴӥ2 ExAիXF04ׯ`Ê:ÐhӪ]6 D FܘKݻt{4A  BF!LǏXa" D<:qKDL;tcltk2/inst/tklibs/ttktheme_radiance/radiance/scale-hd.gif0000644000176000001440000000055512215417550023351 0ustar ripleyusersGIF87a Ǿ,  Bc(ȤQI6 ӣDZla:804 1іG&rb}r  ns!!c""  ȸ ϸԒA;tcltk2/inst/tklibs/ttktheme_radiance/radiance/button-a.gif0000644000176000001440000000200212215417550023407 0ustar ripleyusersGIF89aw|h}i~jklmnopqrwxy{{||{|fgghhƚiǛojpkqlʞr m|r}rsttuuv|wx~y{̳ɷʸ최ռ¨!Created with GIMP! ,vspstnYSntvun- U]\]U')nurXTEHHEHRYrqNDEȳɺPqo [DDABA[ on [ABABB?D nn ZA?>o- ܴYpe?<|@HWiʏ:BIRDTY J:ry 7gıG(ְAЄ5*A6qx͚MtT:#ƌ`:ɣɁ5j0qkoQȝ+WF5t09M$8hȐAW 뢠q#I4iޠ˗I`6A4f QEf$RV}YnF 9S H %T b߿Sϭ2x;7BA;t0^IC<*}Kǀ1 |Էٷ&ciwx u c1 UA  1.4Go}pp0g.D0GT0W HLfds(0k^Sp[\Ұa(@pK#sA|~"v;tcltk2/inst/tklibs/ttktheme_radiance/radiance/combo-rd.gif0000644000176000001440000000070312215417550023366 0ustar ripleyusersGIF87a,FȤQm:NEZ%,xLZKln jN+A2#44$  *&&+ '' ..-PHHA(D`Ç#>L1G BD`&!;tcltk2/inst/tklibs/ttktheme_radiance/radiance/arrowdown-n.gif0000644000176000001440000000054612215417550024146 0ustar ripleyusersGIF87azzynnmzyxwwussrzzx,@e8#L LTJrCĩz hn̥`KKph(0yu]/2/]v]^^   ^]r.1hh1+,i`b# ".-")#mGF#A;tcltk2/inst/tklibs/ttktheme_radiance/radiance/radio-nu.gif0000644000176000001440000000106412215417550023403 0ustar ripleyusersGIF89a@¸ĺĻƽǾǾƿǿǿºûĽżǿ!Created with GIMP! ,|552!"15/#6??6#350=@=:$;+&@%76??@? 8@7 )(' << ,0>>:54*88* 9:- .5;tcltk2/inst/tklibs/ttktheme_radiance/radiance/arrowleft-n.gif0000644000176000001440000000054312215417550024126 0ustar ripleyusersGIF87azzynnmwwuzyyssr,WE@#T$HT*j}Diz (LJ ,ԭy@Fz]]y]1&//{} qsuw-0q/j/0*+q`b! -, (!nGF!A;tcltk2/inst/tklibs/ttktheme_radiance/radiance/combo-n.gif0000644000176000001440000000036712215417550023224 0ustar ripleyusersGIF87aúﶫù,|` CehzMHHttm"5GmpH4l(i:P(DWN`zfo9}]3.wOcTuNJL   r  273"!;tcltk2/inst/tklibs/ttktheme_radiance/radiance/check-nu.gif0000644000176000001440000000060512215417550023362 0ustar ripleyusersGIF89a5úĽ!Created with GIMP! ?,@ !(Jt*`Q`f2k^*Av~g0g1g!2! g$2$#g*232*%Z".343."(( &.``.& +(' ),(A;tcltk2/inst/tklibs/ttktheme_radiance/radiance/arrowleft-a.gif0000644000176000001440000000054212215417550024110 0ustar ripleyusersGIF87aןӠxxwtts𘘘삂{{zoon||z,dA$L T1@J3z!(Ǧc)pC7!2 xFz]#" ]y]!* {} qsuw&qjl- (q`b .+ nGF-A;tcltk2/inst/tklibs/ttktheme_radiance/radiance/radio-du.gif0000644000176000001440000000055412215417550023374 0ustar ripleyusersGIF89a8ĻǾǿȿ!Created with GIMP! ?,tZmA$%Zt:( 4HVx*\ ]@u8'~*' "*! , %% /1k'754 #U# 6N7/ 05A;tcltk2/inst/tklibs/ttktheme_radiance/radiance/tree-h.gif0000644000176000001440000000040112215417550023043 0ustar ripleyusersGIF87a,`aMah \&1tmUcEpHTlJ$:yZzSk se1i71.`5>rokaxY  xQ  kFHS)'!;tcltk2/inst/tklibs/ttktheme_radiance/radiance/sep-h.gif0000644000176000001440000000005012215417550022673 0ustar ripleyusersGIF87a, ;tcltk2/inst/tklibs/ttktheme_radiance/radiance/arrowright-a.gif0000644000176000001440000000054212215417550024273 0ustar ripleyusersGIF87aןӠxxwtts𘘘삂{{zoon||z,dA$L T1@J3z!(Ǧc)po7!2C r5%0x/Fy^, "#]xz *!]z|~ ^rtv&^ijl- (j`b .+ nGF-A;tcltk2/inst/tklibs/ttktheme_radiance/radiance/sizegrip.gif0000644000176000001440000000011612215417550023516 0ustar ripleyusersGIF89a!,#R/܋10rg}aRn_;tcltk2/inst/tklibs/ttktheme_radiance/radiance/scaletrough-v.gif0000644000176000001440000000035112215417550024446 0ustar ripleyusersGIF87a ĻŻżŽ, n%^A9بb -@(E£ HqfDcrjNN(S]u*7]{nqw|yp~}_ C<5;3 2"!;tcltk2/inst/tklibs/ttktheme_radiance/radiance/arrowright-p.gif0000644000176000001440000000054312215417550024313 0ustar ripleyusersGIF87anmkjigᴱzxv̎{yvusqrqn,@#h" VTJb2J &HW0Y,f8_F{_ Bz|'("B|~ &_tvx,ik, *%vb., !!eyGA;tcltk2/inst/tklibs/ttktheme_radiance/radiance/sep-v.gif0000644000176000001440000000005012215417550022711 0ustar ripleyusersGIF87a, ;tcltk2/inst/tklibs/ttktheme_radiance/radiance/arrowup-a.gif0000644000176000001440000000054312215417550023603 0ustar ripleyusersGIF87aӠxxwtts𘘘ϟ{{zoon悂||z,@g41$<T!"z&Ff3!phX0<РM1޻-.-^}v^""~](  (]w *{} irt$^k+  & i`b,)mGF+A;tcltk2/inst/tklibs/ttktheme_radiance/radiance/tab-a.gif0000644000176000001440000000070612215417550022653 0ustar ripleyusersGIF87a,@pH,ȤRYШt*X0!ۆ"xL<Y|N?V h++* //50PPPP&"&P''P(#() )P.-.P$MHÇ#:Tŋ3jJ CI2d%(S4;tcltk2/inst/tklibs/ttktheme_radiance/radiance/scale-ha.gif0000644000176000001440000000056112215417550023343 0ustar ripleyusersGIF87a ȿĻžȿûȾúǾ, !Ȥ "FYYجЀ *(D:]čx ذqOsc&%~so%&)&$ %$&"!!(خA;tcltk2/inst/tklibs/ttktheme_radiance/radiance/tab-n.gif0000644000176000001440000000063112215417550022665 0ustar ripleyusersGIF87aûĻú,ϢPȤi@ 'Єج6I,!H8Z`"hBH18%##G#G$$GG%%$ؼG ͞ G"" <;tcltk2/inst/tklibs/ttktheme_radiance/radiance/combo-rf.gif0000644000176000001440000000124012215417550023365 0ustar ripleyusersGIF87al柂꧌ihg`ⱛu꩏꤅f椇kkjiIJ^jð驏砃ihf¯ꪏ{ed_uޫj~ᜁުi崟ır,Pd4-M^a 35,K]JS2c@N6!T LBM(-.91-_`: -/ ;-0b-9*9[<-\:h*|B#JPE3jܘŊ CIGR\ɲ%FȜIM$MɳOAP9RdѣH"rf+JJuj3>@01ׯ`!( (th-&D;tcltk2/inst/tklibs/ttktheme_radiance/radiance/button-p.gif0000644000176000001440000000174412215417550023442 0ustar ripleyusersGIF89aky^z_ze{`{f|a|g}b}h~hiejkmnojpƅlˆrŊoŽvÏwĐxƓzǔ{͓|eȕ|ffg˗~gh̘qhniriojspkqzulr{|rns~sttԡuuvvףw}x~yڧۨ{ଘۮ쾨¬íïǶȱȷɸ!Created with GIMP! ,jjhbYWVZbhjeXC>WfW-4==<42^icC4BGGHFGFGJd[)BKONNOO:`V4DNROQQRQRUUO\V;D ڒ&t⌚.I ŋ/9 b@,1/_({Iz߀1B&!7k⴩yVS A´iӤEP<sh"K`$$ P0A-m]5/1޶@j&^3`X̘qڶD( -.xqIǀŌ.<0k, €]`Bg;- Ho^ܚ "nBD_k[iEjExOi4= CXsAuOtKq@罬߼lD{J{QX.uPӉjˈluUlYYO彭`ej8h6U0gBYrAp?oFmJxHl޽׼W.kHىhRtU]/fAq@pGZ0lIX.{Oh?ӇhnG{JwRO}OWUqASnD c >J3)uS5isd?Z_b=|f#i1\<*o6 "` (S\ɲ%& <)B͛8sl .JѣF]PN3PJJ*kn@¦`ÊK6l 6X(p MpʝK7n+8!'$LÄ DТLwiJuЃGӨS^Z XsAuOtKq@罬߼lD{J{QX.uPӉjˈluUlYYO彭`ej8h6U0gBYrAp?oFmJxHl޽׼W.kHىhRtU]/fAq@pGZ0lIX.{Oh?ӇhnG{JwRO}OWUqASn˻$-z(qD'exR @Amj!c; EBƯ; @ 5D hZFs&D$82JK̘?.gfΛ-y *hLC # # 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/swaplist.man0000644000176000001440000000521112215417547020412 0ustar ripleyusers[comment {-*- tcl -*- doctools manpage}] [manpage_begin swaplist n 0.1] [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}] [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. [nl] 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 opt] [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" } }] [keywords dialog disjointlistbox listbox] [manpage_end] tcltk2/inst/tklibs/swaplist0.2/pkgIndex.tcl0000644000176000001440000000113712215417547020327 0ustar ripleyusers# 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/example.tcl0000644000176000001440000000025612215417547020212 0ustar ripleyusers#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/swaplist0.2/ChangeLog0000644000176000001440000000166412215417547017631 0ustar ripleyusers2009-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/ico1.0/0000755000176000001440000000000012445051436014747 5ustar ripleyuserstcltk2/inst/tklibs/ico1.0/pkgIndex.tcl0000644000176000001440000000044512215417550017225 0ustar ripleyusers# pkgIndex.tcl -- # # Copyright (c) 2003 ActiveState Corporation. # All rights reserved. # # RCS: @(#) $Id: pkgIndex.tcl,v 1.8 2008/03/12 07:25:49 hobbs Exp $ package ifneeded ico 0.3.1 [list source [file join $dir ico0.tcl]] package ifneeded ico 1.0.3 [list source [file join $dir ico.tcl]] tcltk2/inst/tklibs/ico1.0/ico.tcl0000644000176000001440000012261112215417550016226 0ustar ripleyusers# ico.tcl -- # # Win32 ico manipulation code # # Copyright (c) 2003-2007 Aaron Faupell # Copyright (c) 2003-2004 ActiveState Corporation # # RCS: @(#) $Id: ico.tcl,v 1.28 2008/03/12 07:25:49 hobbs Exp $ # Sample usage: # set file bin/wish.exe # set icos [::ico::icons $file] # set img [::ico::getIcon $file [lindex $icos 1] -format image -res 32] package require Tcl 8.4 # Instantiate vars we need for this package namespace eval ::ico { namespace export icons iconMembers getIcon getIconByName writeIcon copyIcon transparentColor clearCache EXEtoICO # stores cached indices of icons found variable RES array set RES {} # used for 4bpp number conversion variable BITS array set BITS [list {} 0 0000 0 0001 1 0010 2 0011 3 0100 4 \ 0101 5 0110 6 0111 7 1000 8 1001 9 \ 1010 10 1011 11 1100 12 1101 13 1110 14 1111 15 \ \ 00000 00 00001 0F 00010 17 00011 1F \ 00100 27 00101 2F 00110 37 00111 3F \ 01000 47 01001 4F 01010 57 01011 5F \ 01100 67 01101 6F 01110 77 01111 7F \ 10000 87 10001 8F 10010 97 10011 9F \ 10100 A7 10101 AF 10110 B7 10111 BF \ 11000 C7 11001 CF 11010 D7 11011 DF \ 11100 E7 11101 EF 11110 F7 11111 FF] } # icons -- # # List of icons in a file # # ARGS: # file File to extract icon info from. # ?-type? Type of file. If not specified, it is derived from # the file extension. Currently recognized types are # EXE, DLL, ICO, ICL, BMP, and ICODATA # # RETURNS: # list of icon names or numerical IDs # proc ::ico::icons {file args} { parseOpts type $args if {![info exists type]} { # $type wasn't specified - get it from the extension set type [fileext $file] } if {![llength [info commands getIconList$type]]} { return -code error "unsupported file format $type" } getIconList$type [file normalize $file] } # iconMembers -- # # Get info on images which make up an icon # # ARGS: # file File containing icon # name Name of the icon in the file # ?-type? Type of file. If not specified, it is derived from # the file extension. Currently recognized types are # EXE, DLL, ICO, ICL, BMP, and ICODATA # # RETURNS: # list of icons as tuples {name width height bpp} # proc ::ico::iconMembers {file name args} { parseOpts type $args if {![info exists type]} { # $type wasn't specified - get it from the extension set type [fileext $file] } if {![llength [info commands getIconMembers$type]]} { return -code error "unsupported file format $type" } getIconMembers$type [file normalize $file] $name } # getIcon -- # # Get pixel data or image of icon # # ARGS: # file File to extract icon info from. # name Name of image in the file to use. The name is the first element # in the sublists returned by iconMembers. # ?-res? Set the preferred resolution. # ?-bpp? Set the preferred color depth in bits per pixel. # ?-exact? Accept only exact matches for res and bpp. Returns # an error if there is no exact match. # ?-type? Type of file. If not specified, it is derived from # the file extension. Currently recognized types are # EXE, DLL, ICO, ICL, BMP, and ICODATA # ?-format? Output format. Must be one of "image" or "colors" # 'image' will return the name of a Tk image. # 'colors' will return a list of pixel values # ?-image? If output is image, use this as the name of Tk image # created # # RETURNS: # pixel data as a list that could be passed to 'image create' # or the name of a Tk image # proc ::ico::getIcon {file name args} { set image {} set format image set exact 0 set bpp 24 parseOpts {type format image res bpp exact} $args if {![info exists type]} { # $type wasn't specified - get it from the extension set type [fileext $file] } if {![llength [info commands getRawIconData$type]]} { return -code error "unsupported file format $type" } # ICODATA is a pure data type - not a real file if {$type ne "ICODATA"} { set file [file normalize $file] } set mem [getIconMembers$type $file $name] if {![info exists res]} { set icon [lindex $mem 0 0] } elseif {$exact} { set icon [lsearch -inline -glob $mem "* $res $bpp"] if {$icon == ""} { return -code error "No matching icon" } } else { set mem [lsort -integer -index 1 $mem] set match "" foreach x $mem { if {[lindex $x 1] == [lindex $res 0]} { lappend match $x } } if {$match == ""} { # todo: resize a larger icon #return -code error "No matching icon" set match [list [lindex $mem end]] } set match [lsort -integer -decreasing -index 3 $match] foreach x $match { if {[lindex $x 3] <= $bpp} { set icon [lindex $x 0]; break } } if {![info exists icon]} { set icon [lindex $match end 0]} } if {$format eq "name"} { return $icon } set colors [eval [linsert [getRawIconData$type $file $icon] 0 getIconAsColorList]] if {$format eq "image"} { return [createImage $colors $image] } return $colors } # getIconByName -- # # Get pixel data or image of icon name in file. The icon name # is the first element of the sublist from [iconMembers]. # # ARGS: # file File to extract icon info from. # name Name of image in the file to use. The name is the first element # in the sublists returned by iconMembers. # ?-type? Type of file. If not specified, it is derived from # the file extension. Currently recognized types are # EXE, DLL, ICO, ICL, BMP, and ICODATA # ?-format? Output format. Must be one of "image" or "colors" # 'image' will return the name of a Tk image. # 'colors' will return a list of pixel values # ?-image? If output is image, use this as the name of Tk image # created # # RETURNS: # pixel data as a list that could be passed to 'image create' # proc ::ico::getIconByName {file name args} { set format image set image {} parseOpts {type format image} $args if {![info exists type]} { # $type wasn't specified - get it from the extension set type [fileext $file] } if {![llength [info commands getRawIconData$type]]} { return -code error "unsupported file format $type" } # ICODATA is a pure data type - not a real file if {$type ne "ICODATA"} { set file [file normalize $file] } set colors [eval [linsert [getRawIconData$type $file $name] 0 getIconAsColorList]] if {$format eq "image"} { return [createImage $colors $image] } return $colors } # getFileIcon -- # # Get the registered icon for the file under Windows # # ARGS: # file File to get icon for. # # optional arguments and return values are the same as getIcon # proc ::ico::getFileIcon {file args} { set icon "%SystemRoot%\\System32\\shell32.dll,0" if {[file isdirectory $file] || $file == "Folder"} { if {![catch {registry get HKEY_CLASSES_ROOT\\Folder\\DefaultIcon ""} reg]} { set icon $reg } } else { set ext [file extension $file] if {![catch {registry get HKEY_CLASSES_ROOT\\$ext ""} doctype]} { if {![catch {registry get HKEY_CLASSES_ROOT\\$doctype\\CLSID ""} clsid] && \ ![catch {registry get HKEY_CLASSES_ROOT\\CLSID\\$clsid\\DefaultIcon ""} reg]} { set icon $reg } elseif {![catch {registry get HKEY_CLASSES_ROOT\\$doctype\\DefaultIcon ""} reg]} { set icon $reg } } } set index [lindex [split $icon ,] 1] set icon [lindex [split $icon ,] 0] if {$index == ""} { set index 0 } set icon [string trim $icon "@'\" "] while {[regexp -nocase {%([a-z]+)%} $icon -> var]} { set icon [string map [list %$var% $::env($var)] $icon] } set icon [string map [list %1 $file] $icon] if {$index < 0} { if {![catch {eval [list getIcon $icon [string trimleft $index -]] $args} output]} { return $output } set index 0 } return [eval [list getIcon $icon [lindex [icons $icon] $index]] $args] } # writeIcon -- # # Overwrite write image in file with depth/pixel data # # ARGS: # file File to extract icon info from. # name Name of image in the file to use. The name is the first element # in the sublists returned by iconMembers. # bpp bit depth of icon we are writing # data Either pixel color data (as returned by getIcon -format color) # or the name of a Tk image. # ?-type? Type of file. If not specified, it is derived from # the file extension. Currently recognized types are # EXE, DLL, ICO and ICL # # RETURNS: # nothing # proc ::ico::writeIcon {file name bpp data args} { parseOpts type $args if {![info exists type]} { # $type wasn't specified - get it from the extension set type [fileext $file] } if {![llength [info commands writeIcon$type]]} { return -code error "unsupported file format $type" } if {[llength $data] == 1} { set data [getColorListFromImage $data] } elseif {[lsearch -glob [join $data] #*] > -1} { set data [translateColors $data] } if {$bpp != 1 && $bpp != 4 && $bpp != 8 && $bpp != 24 && $bpp != 32} { return -code error "invalid color depth" } set palette {} if {$bpp <= 8} { set palette [getPaletteFromColors $data] if {[lindex $palette 0] > (1 << $bpp)} { return -code error "specified color depth too low" } set data [lindex $palette 2] set palette [lindex $palette 1] append palette [string repeat \000 [expr {(1 << ($bpp + 2)) - [string length $palette]}]] } set and [getAndMaskFromColors $data] set xor [getXORFromColors $bpp $data] # writeIcon$type file index w h bpp palette xor and writeIcon$type [file normalize $file] $name \ [llength [lindex $data 0]] [llength $data] $bpp $palette $xor $and } # copyIcon -- # # Copies an icon directly from one file to another # # ARGS: # file1 File to extract icon info from. # name1 Name of image in the file to use. The name is the first element # in the sublists returned by iconMembers. # file2 File to write icon to. # name2 Name of image in the file to use. The name is the first element # in the sublists returned by iconMembers. # ?-fromtype? Type of source file. If not specified, it is derived from # the file extension. Currently recognized types are # EXE, DLL, ICO, ICL, BMP, and ICODATA # ?-totype? Type of destination file. If not specified, it is derived from # the file extension. Currently recognized types are # EXE, DLL, ICO, ICL, BMP, and ICODATA # # RETURNS: # nothing # proc ::ico::copyIcon {file1 name1 file2 name2 args} { parseOpts {fromtype totype} $args if {![info exists fromtype]} { # $type wasn't specified - get it from the extension set fromtype [fileext $file1] } if {![info exists totype]} { # $type wasn't specified - get it from the extension set totype [fileext $file2] } if {![llength [info commands writeIcon$totype]]} { return -code error "unsupported file format $totype" } if {![llength [info commands getRawIconData$fromtype]]} { return -code error "unsupported file format $fromtype" } set src [getRawIconData$fromtype $file1 $name1] writeIcon $file2 $name2 [lindex $src 2] [eval getIconAsColorList $src] -type $totype } # # transparentColor -- # # Turns on transparency for all pixels in the image that match the color # # ARGS: # img Name of the Tk image to modify, or an image in color list format # color Color in #hex format which will be made transparent # # RETURNS: # the data or image after modification # proc ::ico::transparentColor {img color} { if {[llength $img] == 1} { package require Tk if {[string match "#*" $color]} { set color [scan $color "#%2x%2x%2x"] } set w [image width $img] set h [image height $img] for {set y 0} {$y < $h} {incr y} { for {set x 0} {$x < $w} {incr x} { if {[$img get $x $y] eq $color} {$img transparency set $x $y 1} } } } else { set y 0 foreach row $img { set x 0 foreach px $row { if {$px == $color} {lset img $y $x {}} incr x } incr y } } return $img } # # clearCache -- # # Clears the cache of icon offsets # # ARGS: # file optional filename # # # RETURNS: # nothing # proc ::ico::clearCache {{file {}}} { variable RES if {$file ne ""} { array unset RES $file,* } else { unset RES array set RES {} } } # # EXEtoICO -- # # Convert all icons found in exefile into regular icon files # # ARGS: # exeFile Input EXE filename # ?icoDir? Output ICO directory. Default is the # same directory exeFile is located in # # RETURNS: # nothing # proc ::ico::EXEtoICO {exeFile {icoDir {}}} { variable RES set file [file normalize $exeFile] FindResources $file if {$icoDir == ""} { set icoDir [file dirname $file] } set fh [open $file] fconfigure $fh -eofchar {} -encoding binary -translation lf foreach group $RES($file,group,names) { set dir {} set data {} foreach icon $RES($file,group,$group,members) { seek $fh $RES($file,icon,$icon,offset) start set ico $RES($file,icon,$icon,data) eval [list lappend dir] $ico append data [read $fh [eval calcSize $ico 40]] } # write them out to a file set ifh [open [file join $icoDir [file tail $exeFile]-$group.ico] w+] fconfigure $ifh -eofchar {} -encoding binary -translation lf bputs $ifh sss 0 1 [llength $RES($file,group,$group,members)] set offset [expr {6 + ([llength $RES($file,group,$group,members)] * 16)}] foreach {w h bpp} $dir { set len [calcSize $w $h $bpp 40] lappend fix $offset $len bputs $ifh ccccssii $w $h [expr {$bpp <= 8 ? 1 << $bpp : 0}] 0 1 $bpp $len $offset set offset [expr {$offset + $len}] } puts -nonewline $ifh $data foreach {offset size} $fix { seek $ifh [expr {$offset + 20}] start bputs $ifh i $size } close $ifh } close $fh } ## ## Internal helper commands. ## Some may be appropriate for exposing later, but would need docs ## and make sure they "fit" in the API. ## # gets the file extension as we use it internally (upper case, no '.') proc ::ico::fileext {file} { return [string trimleft [string toupper [file extension $file]] .] } # helper proc to parse optional arguments to some of the public procs proc ::ico::parseOpts {acc opts} { foreach {key val} $opts { set key [string trimleft $key -] if {[lsearch -exact $acc $key] >= 0} { upvar $key $key set $key $val } elseif {$key ne ""} { return -code error "unknown option \"$key\": must be one of $acc" } } } # formats a single color from a binary decimal list format to the #hex format proc ::ico::formatColor {r g b} { format "#%02X%02X%02X" [scan $r %c] [scan $g %c] [scan $b %c] } # translates a color list from the #hex format to the decimal list format # #0000FF {0 0 255} proc ::ico::translateColors {colors} { set new {} foreach line $colors { set tline {} foreach x $line { if {$x eq ""} {lappend tline {}; continue} lappend tline [scan $x "#%2x%2x%2x"] } set new [linsert $new 0 $tline] } return $new } # reads a 32 bit signed integer from the filehandle proc ::ico::getdword {fh} { binary scan [read $fh 4] i* tmp return $tmp } proc ::ico::getword {fh} { binary scan [read $fh 2] s* tmp return $tmp } proc ::ico::getulong {fh} { binary scan [read $fh 4] i tmp return [format %u $tmp] } proc ::ico::getushort {fh} { binary scan [read $fh 2] s tmp return [expr {$tmp & 0x0000FFFF}] } proc ::ico::bputs {fh format args} { puts -nonewline $fh [eval [list binary format $format] $args] } proc ::ico::createImage {colors {name {}}} { package require Tk set h [llength $colors] set w [llength [lindex $colors 0]] if {$name ne ""} { set img [image create photo $name -width $w -height $h] } else { set img [image create photo -width $w -height $h] } if {0} { # if image supported "" colors as transparent pixels, # we could use this much faster op $img put -to 0 0 $colors } else { for {set x 0} {$x < $w} {incr x} { for {set y 0} {$y < $h} {incr y} { set clr [lindex $colors $y $x] if {$clr ne ""} { $img put -to $x $y $clr } } } } return $img } # return a list of colors in the #hex format from raw icon data # returned by readDIB proc ::ico::getIconAsColorList {w h bpp palette xor and} { # Create initial empty color array that we'll set indices in set colors {} set row {} set empty {} for {set x 0} {$x < $w} {incr x} { lappend row $empty } for {set y 0} {$y < $h} {incr y} { lappend colors $row } set x 0 set y [expr {$h-1}] if {$bpp == 1} { binary scan $xor B* xorBits foreach i [split $xorBits {}] a [split $and {}] { if {$x == $w} { set x 0; incr y -1 } if {$a == 0} { lset colors $y $x [lindex $palette $i] } incr x } } elseif {$bpp == 4} { variable BITS binary scan $xor B* xorBits set i 0 foreach a [split $and {}] { if {$x == $w} { set x 0; incr y -1 } if {$a == 0} { set bits [string range $xorBits $i [expr {$i+3}]] lset colors $y $x [lindex $palette $BITS($bits)] } incr i 4 incr x } } elseif {$bpp == 8} { foreach i [split $xor {}] a [split $and {}] { if {$x == $w} { set x 0; incr y -1 } if {$a == 0} { lset colors $y $x [lindex $palette [scan $i %c]] } incr x } } elseif {$bpp == 16} { variable BITS binary scan $xor b* xorBits set i 0 foreach a [split $and {}] { if {$x == $w} { set x 0; incr y -1 } if {$a == 0} { set b1 [string range $xorBits $i [expr {$i+4}]] set b2 [string range $xorBits [expr {$i+5}] [expr {$i+9}]] set b3 [string range $xorBits [expr {$i+10}] [expr {$i+14}]] lset colors $y $x "#$BITS($b3)$BITS($b2)$BITS($b1)" } incr i 16 incr x } } elseif {$bpp == 24} { foreach {b g r} [split $xor {}] a [split $and {}] { if {$x == $w} { set x 0; incr y -1 } if {$a == 0} { lset colors $y $x [formatColor $r $g $b] } incr x } } elseif {$bpp == 32} { foreach {b g r n} [split $xor {}] a [split $and {}] { if {$x == $w} { set x 0; incr y -1 } if {$a == 0} { lset colors $y $x [formatColor $r $g $b] } incr x } } return $colors } # creates a binary formatted AND mask by reading a list of colors in the decimal list format # and checking for empty colors which designate transparency proc ::ico::getAndMaskFromColors {colors} { set and {} foreach line $colors { set l {} foreach x $line {append l [expr {$x eq ""}]} append l [string repeat 0 [expr {[string length $l] % 32}]] foreach {a b c d e f g h} [split $l {}] { append and [binary format B8 $a$b$c$d$e$f$g$h] } } return $and } # creates a binary formatted XOR mask in the specified depth format from # a list of colors in the decimal list format proc ::ico::getXORFromColors {bpp colors} { set xor {} if {$bpp == 1} { foreach line $colors { foreach {a b c d e f g h} $line { foreach x {a b c d e f g h} { if {[set $x] == ""} {set $x 0} } binary scan $a$b$c$d$e$f$g$h bbbbbbbb h g f e d c b a append xor [binary format b8 $a$b$c$d$e$f$g$h] } } } elseif {$bpp == 4} { foreach line $colors { foreach {a b} $line { if {$a == ""} {set a 0} if {$b == ""} {set b 0} binary scan $a$b b4b4 b a append xor [binary format b8 $a$b] } } } elseif {$bpp == 8} { foreach line $colors { foreach x $line { if {$x == ""} {set x 0} append xor [binary format c $x] } } } elseif {$bpp == 24} { foreach line $colors { foreach x $line { if {![llength $x]} { append xor [binary format ccc 0 0 0] } else { foreach {a b c n} $x { append xor [binary format ccc $c $b $a] } } } } } elseif {$bpp == 32} { foreach line $colors { foreach x $line { if {![llength $x]} { append xor [binary format cccc 0 0 0 0] } else { foreach {a b c n} $x { if {$n == ""} {set n 0} append xor [binary format cccc $c $b $a $n] } } } } } return $xor } # translates a Tk image into a list of colors in the {r g b} format # one element per pixel and {} designating transparent # used by writeIcon when writing from a Tk image proc ::ico::getColorListFromImage {img} { package require Tk set w [image width $img] set h [image height $img] set r {} for {set y [expr $h - 1]} {$y > -1} {incr y -1} { set l {} for {set x 0} {$x < $w} {incr x} { if {[$img transparency get $x $y]} { lappend l {} } else { lappend l [$img get $x $y] } } lappend r $l } return $r } # creates a palette from a list of colors in the decimal list format # a palette consists of 3 values, the number of colors, the palette entry itself, # and the color list transformed to point to palette entries instead of color names # the palette entry itself is stored as 32bpp in "G B R padding" order proc ::ico::getPaletteFromColors {colors} { set palette "\x00\x00\x00\x00" array set tpal {{0 0 0} 0} set new {} set i 1 foreach line $colors { set tline {} foreach x $line { if {$x eq ""} {lappend tline {}; continue} if {![info exists tpal($x)]} { foreach {a b c n} $x { append palette [binary format cccc $c $b $a 0] } set tpal($x) $i incr i } lappend tline $tpal($x) } lappend new $tline } return [list $i $palette $new] } # calculate byte size of an icon. # often passed $w twice because $h is double $w in the binary data proc ::ico::calcSize {w h bpp {offset 0}} { set s [expr {int(($w*$h) * ($bpp/8.0)) \ + ((($w*$h) + ($h*($w%32)))/8) + $offset}] if {$bpp <= 8} { set s [expr {$s + (1 << ($bpp + 2))}] } return $s } # read a Device Independent Bitmap from the current offset, return: # {width height depth palette XOR_mask AND_mask} proc ::ico::readDIB {fh} { binary scan [read $fh 16] x4iix2s w h bpp set h [expr {$h / 2}] seek $fh 24 current set palette [list] if {$bpp == 1 || $bpp == 4 || $bpp == 8} { set colors [read $fh [expr {1 << ($bpp + 2)}]] foreach {b g r x} [split $colors {}] { lappend palette [formatColor $r $g $b] } } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} { # do nothing here } else { return -code error "unsupported color depth: $bpp" } set xor [read $fh [expr {int(($w * $h) * ($bpp / 8.0))}]] set and1 [read $fh [expr {(($w * $h) + ($h * ($w % 32))) / 8}]] set and {} set row [expr {((($w - 1) / 32) * 32 + 32) / 8}] set len [expr {$row * $h}] for {set i 0} {$i < $len} {incr i $row} { binary scan [string range $and1 $i [expr {$i + $row}]] B$w tmp append and $tmp } return [list $w $h $bpp $palette $xor $and] } # read a Device Independent Bitmap from raw data, return: # {width height depth palette XOR_mask AND_mask} proc ::ico::readDIBFromData {data loc} { # Read info from location binary scan $data @${loc}x4iix2s w h bpp set h [expr {$h / 2}] # Move over w/h/bpp info + magic offset to start of DIB set cnt [expr {$loc + 16 + 24}] set palette [list] if {$bpp == 1 || $bpp == 4 || $bpp == 8} { # Could do: [binary scan $data @${cnt}c$len colors] # and iter over colors, but this is more consistent with $fh version set len [expr {1 << ($bpp + 2)}] set colors [string range $data $cnt [expr {$cnt + $len - 1}]] foreach {b g r x} [split $colors {}] { lappend palette [formatColor $r $g $b] } incr cnt $len } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} { # do nothing here } else { return -code error "unsupported color depth: $bpp" } # Use -1 to account for string range inclusiveness set end [expr {$cnt + int(($w * $h) * ($bpp / 8.0)) - 1}] set xor [string range $data $cnt $end] set and1 [string range $data [expr {$end + 1}] \ [expr {$end + ((($w * $h) + ($h * ($w % 32))) / 8) - 1}]] set and {} set row [expr {((($w - 1) / 32) * 32 + 32) / 8}] set len [expr {$row * $h}] for {set i 0} {$i < $len} {incr i $row} { # Has to be decoded by row, in order binary scan [string range $and1 $i [expr {$i + $row}]] B$w tmp append and $tmp } return [list $w $h $bpp $palette $xor $and] } proc ::ico::getIconListICO {file} { set fh [open $file r] fconfigure $fh -eofchar {} -encoding binary -translation lf if {"[getword $fh] [getword $fh]" ne "0 1"} { return -code error "not an icon file" } close $fh return 0 } proc ::ico::getIconListICODATA {data} { if {[binary scan $data sss h1 h2 num] != 3 || $h1 != 0 || $h2 != 1} { return -code error "not icon data" } return 0 } proc ::ico::getIconListBMP {file} { set fh [open $file] if {[read $fh 2] != "BM"} { close $fh; return -code error "not a BMP file" } close $fh return 0 } proc ::ico::getIconListEXE {file} { variable RES set file [file normalize $file] if {[FindResources $file] > -1} { return $RES($file,group,names) } else { return "" } } # returns a list of images that make up the named icon # as tuples {name width height bpp}. Called by [iconMembers] proc ::ico::getIconMembersICO {file name} { variable RES if {$name ne "0"} { return -code error "no icon \"$name\"" } set file [file normalize $file] if {[info exists RES($file,group,$name,members)]} { set ret "" foreach x $RES($file,group,$name,members) { lappend ret [linsert $RES($file,icon,$x,data) 0 $x] } return $ret } set fh [open $file r] fconfigure $fh -eofchar {} -encoding binary -translation lf # both words must be read to keep in sync with later reads if {"[getword $fh] [getword $fh]" ne "0 1"} { close $fh return -code error "not an icon file" } set ret "" set num [getword $fh] for {set i 0} {$i < $num} {incr i} { set info "" lappend RES($file,group,$name,members) $i lappend info [scan [read $fh 1] %c] [scan [read $fh 1] %c] set bpp [scan [read $fh 1] %c] if {$bpp == 0} { set orig [tell $fh] seek $fh 9 current seek $fh [expr {[getdword $fh] + 14}] start lappend info [getword $fh] seek $fh $orig start } else { lappend info [expr {int(sqrt($bpp))}] } lappend ret [linsert $info 0 $i] set RES($file,icon,$i,data) $info seek $fh 13 current } close $fh return $ret } # returns a list of images that make up the named icon # as tuples {name width height bpp}. Called by [iconMembers] proc ::ico::getIconMembersICODATA {data} { if {[binary scan $data sss h1 h2 num] != 3 || $h1 != 0 || $h2 != 1} { return -code error "not icon data" } set r {} set cnt 6 for {set i 0} {$i < $num} {incr i} { if {[binary scan $data @${cnt}ccc w h bpp] != 3} { return -code error "error decoding icon data" } incr cnt 3 set info [list $i $w $h] if {$bpp == 0} { set off [expr {$cnt + 9}] binary scan $data @${off}i off incr off 14 binary scan $data @${off}s bpp lappend info $bpp } else { lappend info [expr {int(sqrt($bpp))}] } lappend r $info incr cnt 13 } return $r } # returns a list of images that make up the named icon # as tuples {name width height bpp}. Called by [iconMembers] proc ::ico::getIconMembersBMP {file {name 0}} { if {$name ne "0"} { return -code error "no icon \"$name\"" } set fh [open $file] if {[read $fh 2] != "BM"} { close $fh; return -code error "not a BMP file" } seek $fh 14 start binary scan [read $fh 16] x4iix2s w h bpp close $fh return [list 1 $w $h $bpp] } # returns a list of images that make up the named icon # as tuples {name width height bpp}. Called by [iconMembers] proc ::ico::getIconMembersEXE {file name} { variable RES set file [file normalize $file] FindResources $file if {![info exists RES($file,group,$name,members)]} { return -code error "no icon \"$name\"" } set ret "" foreach x $RES($file,group,$name,members) { lappend ret [linsert $RES($file,icon,$x,data) 0 $x] } return $ret } # returns an icon in the form: # {width height depth palette xor_mask and_mask} proc ::ico::getRawIconDataICO {file name} { set fh [open $file r] fconfigure $fh -eofchar {} -encoding binary -translation lf # both words must be read to keep in sync with later reads if {"[getword $fh] [getword $fh]" ne "0 1"} { close $fh return -code error "not an icon file" } set num [getword $fh] if {![string is integer -strict $name] || $name < 0 || $name >= $num} { return -code error "no icon \"$name\"" } seek $fh [expr {(16 * $name) + 12}] current seek $fh [getdword $fh] start # readDIB returns: {w h bpp palette xor and} set dib [readDIB $fh] close $fh return $dib } # returns an icon in the form: # {width height depth palette xor_mask and_mask} proc ::ico::getRawIconDataICODATA {data name} { if {[binary scan $data sss h1 h2 num] != 3 || $h1 != 0 || $h2 != 1} { return -code error "not icon data" } if {![string is integer -strict $name] || $name < 0 || $name >= $num} { return -code error "No icon $name" } # Move to ico location set cnt [expr {6 + (16 * $name) + 12}] binary scan $data @${cnt}i loc # readDIB returns: {w h bpp palette xor and} set dib [readDIBFromData $data $loc] return $dib } # returns an icon in the form: # {width height depth palette xor_mask and_mask} proc ::ico::getRawIconDataBMP {file {name 1}} { if {$name ne "1"} {return -code error "No icon \"$name\""} set fh [open $file] if {[read $fh 2] != "BM"} { close $fh; return -code error "not a BMP file" } seek $fh 14 start binary scan [read $fh 16] x4iix2s w h bpp seek $fh 24 current set palette [list] if {$bpp == 1 || $bpp == 4 || $bpp == 8} { set colors [read $fh [expr {1 << ($bpp + 2)}]] foreach {b g r x} [split $colors {}] { lappend palette [formatColor $r $g $b] } } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} { # do nothing here } else { return -code error "unsupported color depth: $bpp" } set xor [read $fh [expr {int(($w * $h) * ($bpp / 8.0))}]] set and [string repeat 0 [expr {$w * $h}]] close $fh return [list $w $h $bpp $palette $xor $and] } # returns an icon in the form: # {width height depth palette xor_mask and_mask} proc ::ico::getRawIconDataEXE {file name} { variable RES set file [file normalize $file] FindResources $file if {![info exists RES($file,icon,$name,offset)]} { error "No icon \"$name\"" } set fh [open $file] fconfigure $fh -eofchar {} -encoding binary -translation lf seek $fh $RES($file,icon,$name,offset) start # readDIB returns: {w h bpp palette xor and} set dib [readDIB $fh] close $fh return $dib } proc ::ico::writeIconICO {file name w h bpp palette xor and} { if {![file exists $file]} { set fh [open $file w+] fconfigure $fh -eofchar {} -encoding binary -translation lf set num 0 } else { set fh [open $file r+] fconfigure $fh -eofchar {} -encoding binary -translation lf if {"[getword $fh] [getword $fh]" ne "0 1"} { close $fh return -code error "not an icon file" } set num [getword $fh] seek $fh [expr {6 + (16 * $num)}] start } set size [expr {[string length $palette] + [string length $xor] + [string length $and]}] set newicon [binary format iiissiiiiii 40 $w [expr {$h * 2}] 1 $bpp 0 $size 0 0 0 0]$palette$xor$and set data {} for {set i 0} {$i < $num} {incr i} { binary scan [read $fh 24] ix16i a b seek $fh -24 current lappend data [read $fh [expr {$a + $b}]] } if {![string is integer -strict $name] || $name < 0 || $name >= $num} { set name [llength $data] lappend data $newicon } else { set data [lreplace $data $name $name $newicon] } set num [llength $data] seek $fh 0 start bputs $fh sss 0 1 $num set offset [expr {6 + (16 * $num)}] foreach x $data { binary scan $x x4iix2s w h bpp set len [string length $x] # use original height in icon table header bputs $fh ccccssii $w [expr {$h / 2}] [expr {$bpp <= 8 ? 1 << $bpp : 0}] 0 0 $bpp $len $offset incr offset $len } puts -nonewline $fh [join $data {}] close $fh return $name } proc ::ico::writeIconICODATA {file name w h bpp palette xor and} { upvar 2 [file tail $file] input if {![info exists input] || ([binary scan $input sss h1 h2 num] != 3 || $h1 != 0 || $h2 != 1)} { set num 0 } set size [expr {[string length $palette] + [string length $xor] + [string length $and]}] set newicon [binary format iiissiiiiii 40 $w [expr {$h * 2}] 1 $bpp 0 $size 0 0 0 0]$palette$xor$and set readpos [expr {6 + (16 * $num)}] set data {} for {set i 0} {$i < $num} {incr i} { binary scan $input @{$readpos}ix16i a b lappend data [string range $data $readpos [expr {$readpos + $a + $b}]] incr readpos [expr {$readpos + $a + $b}] } if {![string is integer -strict $name] || $name < 0 || $name >= $num} { set name [llength $data] lappend data $newicon } else { set data [lreplace $data $name $name $newicon] } set num [llength $data] set new [binary format sss 0 1 $num] set offset [expr {6 + (16 * $num)}] foreach x $data { binary scan $x x4iix2s w h bpp set len [string length $x] # use original height in icon table header append new [binary format ccccssii $w [expr {$h / 2}] [expr {$bpp <= 8 ? 1 << $bpp : 0}] 0 0 $bpp $len $offset] incr offset $len } set input $new append input [join $data {}] return $name } proc ::ico::writeIconBMP {file name w h bpp palette xor and} { set fh [open $file w+] fconfigure $fh -eofchar {} -encoding binary -translation lf set size [expr {[string length $palette] + [string length $xor]}] # bitmap header: magic, file size, reserved, reserved, offset of bitmap data bputs $fh a2issi BM [expr {14 + 40 + $size}] 0 0 54 bputs $fh iiissiiiiii 40 $w $h 1 $bpp 0 $size 0 0 0 0 puts -nonewline $fh $palette$xor close $fh } proc ::ico::writeIconEXE {file name w h bpp palette xor and} { variable RES set file [file normalize $file] set members [getIconMembersEXE $file $name] if {![info exists RES($file,icon,$name,data)]} { return -code error "no icon \"$name\"" } if {![string match "* $w $h $bpp" $RES($file,icon,$name,data)]} { return -code error "icon format differs from original" } set fh [open $file r+] fconfigure $fh -eofchar {} -encoding binary -translation lf seek $fh [expr {$RES($file,icon,$name,offset) + 40}] start puts -nonewline $fh $palette$xor$and close $fh } proc ::ico::FindResources {file} { variable RES if {[info exists RES($file,group,names)]} { return [llength $RES($file,group,names)] } set fh [open $file] fconfigure $fh -eofchar {} -encoding binary -translation lf if {[read $fh 2] ne "MZ"} { close $fh return -code error "unknown file format" } seek $fh 60 start seek $fh [getword $fh] start set sig [read $fh 4] seek $fh -4 current if {$sig eq "PE\000\000"} { return [FindResourcesPE $fh $file] } elseif {[string match NE* $sig]} { return [FindResourcesNE $fh $file] } else { return -code error "unknown file format" } } # parse the resource table of 16 bit windows files for icons proc ::ico::FindResourcesNE {fh file} { variable RES seek $fh 36 current seek $fh [expr {[getword $fh] - 38}] current set base [tell $fh] set shift [expr {int(pow(2, [getushort $fh]))}] while {[set type [expr {[getushort $fh] & 0x7fff}]] != 0} { set num [getushort $fh] if {$type != 3 && $type != 14} { seek $fh [expr {($num * 12) + 4}] current continue } set type [string map {3 icon 14 group} $type] seek $fh 4 current for {set i 0} {$i < $num} {incr i} { set offset [expr {[getushort $fh] * $shift}] seek $fh 4 current set name [getNEResName $fh $base [getushort $fh]] set RES($file,$type,$name,offset) $offset lappend RES($file,$type,names) $name seek $fh 4 current } } if {[array names RES $file,*] == ""} { close $fh return -1 } foreach x [array names RES $file,group,*,offset] { seek $fh [expr {$RES($x) + 4}] start binary scan [read $fh 2] s a set x [lindex [split $x ,] 2] for {set i 0} {$i < $a} {incr i} { binary scan [read $fh 14] x12s n lappend RES($file,group,$x,members) $n } } foreach x [array names RES $file,icon,*,offset] { seek $fh [expr {$RES($x)}] start set x [lindex [split $x ,] 2] binary scan [read $fh 16] x4iix2s w h bpp set RES($file,icon,$x,data) [list $w [expr {$h / 2}] $bpp] } close $fh return [llength $RES($file,group,names)] } proc ::ico::getNEResName {fh base data} { if {$data == 0} { return 0 } binary scan $data b* tmp if {[string index $tmp 0] == 0} { set cur [tell $fh] seek $fh [expr {$data + $base}] start binary scan [read $fh 1] c len set name [read $fh $len] seek $fh $cur start return $name } else { return [expr {$data & 0x7fff}] } } # parse the resource tree of 32 bit windows files for icons proc ::ico::FindResourcesPE {fh file} { variable RES # find the .rsrc section by reading the coff header binary scan [read $fh 24] x6sx12s sections headersize seek $fh $headersize current for {set i 0} {$i < $sections} {incr i} { binary scan [read $fh 40] a8x4ix4i type baserva base if {[string match .rsrc* $type]} {break} } # no resource section found = no icons if {![string match .rsrc* $type]} { close $fh return -1 } seek $fh $base start seek $fh 12 current # number of entries in the resource table. each one is a different resource type set entries [expr {[getushort $fh] + [getushort $fh]}] for {set i 0} {$i < $entries} {incr i} { set type [getulong $fh] set offset [expr {[getulong $fh] & 0x7fffffff}] if {$type != 3 && $type != 14} {continue} set type [string map {3 icon 14 group} $type] set cur [tell $fh] seek $fh [expr {$base + $offset + 12}] start set entries2 [expr {[getushort $fh] + [getushort $fh]}] for {set i2 0} {$i2 < $entries2} {incr i2} { set name [getPEResName $fh $base [getulong $fh]] lappend RES($file,$type,names) $name set offset [expr {[getulong $fh] & 0x7fffffff}] set cur2 [tell $fh] seek $fh [expr {$offset + $base + 12}] start set entries3 [expr {[getushort $fh] + [getushort $fh]}] for {set i3 0} {$i3 < $entries3} {incr i3} { seek $fh 4 current set offset [expr {[getulong $fh] & 0x7fffffff}] set cur3 [tell $fh] seek $fh [expr {$offset + $base}] start set rva [getulong $fh] set RES($file,$type,$name,offset) [expr {$rva - $baserva + $base}] seek $fh $cur3 start } seek $fh $cur2 start } seek $fh $cur start } if {[array names RES $file,*] == ""} { close $fh return -1 } foreach x [array names RES $file,group,*,offset] { seek $fh [expr {$RES($x) + 4}] start binary scan [read $fh 2] s a set x [lindex [split $x ,] 2] for {set i 0} {$i < $a} {incr i} { binary scan [read $fh 14] x12s n lappend RES($file,group,$x,members) $n } } foreach x [array names RES $file,icon,*,offset] { seek $fh [expr {$RES($x)}] start set x [lindex [split $x ,] 2] binary scan [read $fh 16] x4iix2s w h bpp set RES($file,icon,$x,data) [list $w [expr {$h / 2}] $bpp] } close $fh return [llength $RES($file,group,names)] } proc ::ico::getPEResName {fh start data} { if {($data & 0x80000000) != 0} { set cur [tell $fh] seek $fh [expr {($data & 0x7fffffff) + $start}] start set len [getushort $fh] set name [read $fh [expr {$len * 2}]] seek $fh $cur start return [encoding convertfrom unicode $name] } else { return $data } } interp alias {} ::ico::getIconListDLL {} ::ico::getIconListEXE interp alias {} ::ico::getIconMembersDLL {} ::ico::getIconMembersEXE interp alias {} ::ico::getRawIconDataDLL {} ::ico::getRawIconDataEXE interp alias {} ::ico::writeIconDLL {} ::ico::writeIconEXE interp alias {} ::ico::getIconListICL {} ::ico::getIconListEXE interp alias {} ::ico::getIconMembersICL {} ::ico::getIconMembersEXE interp alias {} ::ico::getRawIconDataICL {} ::ico::getRawIconDataEXE interp alias {} ::ico::writeIconICL {} ::ico::writeIconEXE package provide ico 1.0.3 tcltk2/inst/tklibs/ico1.0/ico0.tcl0000644000176000001440000010475512215417550016317 0ustar ripleyusers# ico.tcl -- # # Win32 ico manipulation code # # Copyright (c) 2003 Aaron Faupell # Copyright (c) 2003-2004 ActiveState Corporation # # RCS: @(#) $Id: ico0.tcl,v 1.2 2007/02/23 23:28:33 hobbs Exp $ # JH: speed has been considered in these routines, although they # may not be fully optimized. Running EXEtoICO on explorer.exe, # which has nearly 100 icons, takes .2 secs on a P4/2.4ghz machine. # # Sample usage: # set file bin/wish.exe # set icos [::ico::getIconList $file] # set img [::ico::getIcon $file 1 -format image] package require Tcl 8.4 # Instantiate vars we need for this package namespace eval ::ico { namespace export getIconList getIcon writeIcon copyIcon transparentColor clearCache EXEtoICO # stores cached indices of icons found variable ICONS array set ICONS {} # used for 4bpp number conversion variable BITS array set BITS [list {} 0 0000 0 0001 1 0010 2 0011 3 0100 4 \ 0101 5 0110 6 0111 7 1000 8 1001 9 \ 1010 10 1011 11 1100 12 1101 13 1110 14 1111 15 \ \ 00000 00 00001 0F 00010 17 00011 1F \ 00100 27 00101 2F 00110 37 00111 3F \ 01000 47 01001 4F 01010 57 01011 5F \ 01100 67 01101 6F 01110 77 01111 7F \ 10000 87 10001 8F 10010 97 10011 9F \ 10100 A7 10101 AF 10110 B7 10111 BF \ 11000 C7 11001 CF 11010 D7 11011 DF \ 11100 E7 11101 EF 11110 F7 11111 FF] } # getIconList -- # # List of icons in the file (each element a list of w h and bpp) # # ARGS: # file File to extra icon info from. # ?-type? Type of file. If not specified, it is derived from # the file extension. Currently recognized types are # EXE, DLL, ICO and ICL # # RETURNS: # list of icons' dimensions as tuples {width height bpp} # proc ::ico::getIconList {file args} { parseOpts type $args if {![info exists type]} { # $type wasn't specified - get it from the extension set type [fileext $file] } if {![llength [info commands getIconList$type]]} { return -code error "unsupported file format $type" } getIconList$type [file normalize $file] } # getIcon -- # # Get pixel data or image of icon @ index in file # # ARGS: # file File to extra icon info from. # index Index of icon in the file to use. The ordering is the # same as returned by getIconList. (0-based) # ?-type? Type of file. If not specified, it is derived from # the file extension. Currently recognized types are # EXE, DLL, ICO and ICL # ?-format? Output format. Must be one of "image" or "colors" # 'image' will return the name of a Tk image. # 'colors' will return a list of pixel values # ?-name? If output is image, use this as the name of Tk image # created # # RETURNS: # pixel data as a list that could be passed to 'image create' # proc ::ico::getIcon {file index args} { set name {} set format image parseOpts {type format name} $args if {![info exists type]} { # $type wasn't specified - get it from the extension set type [fileext $file] } if {![llength [info commands getRawIconData$type]]} { return -code error "unsupported file format $type" } # ICODATA is a pure data type - not a real file if {$type ne "ICODATA"} { set file [file normalize $file] } set colors [eval [linsert [getRawIconData$type $file $index] 0 getIconAsColorList]] if {$format eq "image"} { return [createImage $colors $name] } return $colors } # writeIcon -- # # Overwrite write icon @ index in file of specific type with depth/pixel data # # ARGS: # file File to extra icon info from. # index Index of icon in the file to use. The ordering is the # same as returned by getIconList. (0-based) # bpp bit depth of icon we are writing # data Either pixel color data (as returned by getIcon -format color) # or the name of a Tk image. # ?-type? Type of file. If not specified, it is derived from # the file extension. Currently recognized types are # EXE, DLL, ICO and ICL # # RETURNS: # Tk image based on the specified icon # proc ::ico::writeIcon {file index bpp data args} { parseOpts type $args if {![info exists type]} { # $type wasn't specified - get it from the extension set type [fileext $file] } if {![llength [info commands writeIcon$type]]} { return -code error "unsupported file format $type" } if {[llength $data] == 1} { set data [getColorListFromImage $data] } elseif {[lsearch -glob [join $data] #*] > -1} { set data [translateColors $data] } if {$bpp != 1 && $bpp != 4 && $bpp != 8 && $bpp != 24 && $bpp != 32} { return -code error "invalid color depth" } set palette {} if {$bpp <= 8} { set palette [getPaletteFromColors $data] if {[lindex $palette 0] > (1 << $bpp)} { return -code error "specified color depth too low" } set data [lindex $palette 2] set palette [lindex $palette 1] append palette [string repeat \000 [expr {(1 << ($bpp + 2)) - [string length $palette]}]] } set and [getAndMaskFromColors $data] set xor [getXORFromColors $bpp $data] # writeIcon$type file index w h bpp palette xor and writeIcon$type [file normalize $file] $index \ [llength [lindex $data 0]] [llength $data] $bpp $palette $xor $and } # copyIcon -- # # Copies an icon directly from one file to another # # ARGS: # file File to extract icon info from. # index Index of icon in the file to use. The ordering is the # same as returned by getIconList. (0-based) # ?-fromtype? Type of source file. If not specified, it is derived from # the file extension. Currently recognized types are # EXE, DLL, ICO and ICL # ?-totype? Type of destination file. If not specified, it is derived from # the file extension. Currently recognized types are # EXE, DLL, ICO and ICL # # RETURNS: # nothing # proc ::ico::copyIcon {f1 i1 f2 i2 args} { parseOpts {fromtype totype} $args if {![info exists fromtype]} { # $type wasn't specified - get it from the extension set fromtype [fileext $f1] } if {![info exists totype]} { # $type wasn't specified - get it from the extension set totype [fileext $f2] } if {![llength [info commands writeIcon$totype]]} { return -code error "unsupported file format $totype" } if {![llength [info commands getRawIconData$fromtype]]} { return -code error "unsupported file format $fromtype" } set src [getRawIconData$fromtype $f1 $i1] writeIcon $f2 $i2 [lindex $src 2] [eval getIconAsColorList $src] -type $totype } # # transparentColor -- # # Turns on transparency for all pixels in the image that match the color # # ARGS: # img Name of the Tk image to modify, or an image in color list format # color Color in #hex format which will be made transparent # # RETURNS: # the data or image after modification # proc ::ico::transparentColor {img color} { if {[llength $img] == 1} { package require Tk if {[string match "#*" $color]} { set color [scan $color "#%2x%2x%2x"] } set w [image width $img] set h [image height $img] for {set y 0} {$y < $h} {incr y} { for {set x 0} {$x < $w} {incr x} { if {[$img get $x $y] eq $color} {$img transparency set $x $y 1} } } } else { set y 0 foreach row $img { set x 0 foreach px $row { if {$px == $color} {lset img $y $x {}} incr x } incr y } } return $img } # # clearCache -- # # Clears the cache of icon offsets # # ARGS: # file optional filename # # # RETURNS: # nothing # proc ::ico::clearCache {{file {}}} { variable ICONS if {$file ne ""} { array unset ICONS $file,* } else { unset ICONS array set ICONS {} } } # # EXEtoICO -- # # Convert all icons found in exefile into a regular icon file # # ARGS: # exeFile Input EXE filename # icoFile Output ICO filename # # RETURNS: # nothing # proc ::ico::EXEtoICO {exeFile icoFile} { variable ICONS set file [file normalize $exeFile] set cnt [SearchForIcos $file] set dir {} set data {} set fh [open $file] fconfigure $fh -eofchar {} -encoding binary -translation lf for {set i 0} {$i <= $cnt} {incr i} { seek $fh $ICONS($file,$i) start set ico $ICONS($file,$i,data) eval [list lappend dir] $ico append data [read $fh [eval calcSize $ico 40]] } close $fh # write them out to a file set ifh [open $icoFile w+] fconfigure $ifh -eofchar {} -encoding binary -translation lf bputs $ifh sss 0 1 [expr {$cnt + 1}] set offset [expr {6 + (($cnt + 1) * 16)}] foreach {w h bpp} $dir { set colors 0 if {$bpp <= 8} {set colors [expr {1 << $bpp}]} set s [calcSize $w $h $bpp 40] lappend fix $offset $s bputs $ifh ccccssii $w $h $colors 0 1 $bpp $s $offset set offset [expr {$offset + $s}] } puts -nonewline $ifh $data foreach {offset size} $fix { seek $ifh [expr {$offset + 20}] start bputs $ifh i $size } close $ifh } ## ## Internal helper commands. ## Some may be appropriate for exposing later, but would need docs ## and make sure they "fit" in the API. ## # gets the file extension as we use it internally (upper case, no '.') proc ::ico::fileext {file} { return [string trimleft [string toupper [file extension $file]] .] } # helper proc to parse optional arguments to some of the public procs proc ::ico::parseOpts {acc opts} { foreach {key val} $opts { set key [string trimleft $key -] if {[lsearch -exact $acc $key] >= 0} { upvar $key $key set $key $val } elseif {$key ne ""} { return -code error "unknown option \"$key\": must be one of $acc" } } } # formats a single color from a binary decimal list format to the #hex format proc ::ico::formatColor {r g b} { format "#%02X%02X%02X" [scan $r %c] [scan $g %c] [scan $b %c] } # translates a color list from the #hex format to the decimal list format # #0000FF {0 0 255} proc ::ico::translateColors {colors} { set new {} foreach line $colors { set tline {} foreach x $line { if {$x eq ""} {lappend tline {}; continue} lappend tline [scan $x "#%2x%2x%2x"] } set new [linsert $new 0 $tline] } return $new } proc ::ico::getdword {fh} { binary scan [read $fh 4] i* tmp return $tmp } proc ::ico::getword {fh} { binary scan [read $fh 2] s* tmp return $tmp } proc ::ico::getulong {fh} { binary scan [read $fh 4] i tmp return [format %u $tmp] } proc ::ico::getushort {fh} { binary scan [read $fh 2] s tmp return [expr {$tmp & 0x0000FFFF}] } # binary puts proc ::ico::bputs {fh format args} { puts -nonewline $fh [eval [list binary format $format] $args] } # creates a Tk image from a list of colors in the #hex format proc ::ico::createImage {colors {name {}}} { package require Tk set h [llength $colors] set w [llength [lindex $colors 0]] if {$name ne ""} { set img [image create photo $name -width $w -height $h] } else { set img [image create photo -width $w -height $h] } if {0} { # if image supported "" colors as transparent pixels, # we could use this much faster op $img put -to 0 0 $colors } else { for {set x 0} {$x < $w} {incr x} { for {set y 0} {$y < $h} {incr y} { set clr [lindex $colors $y $x] if {$clr ne ""} { $img put -to $x $y $clr } } } } return $img } # return a list of colors in the #hex format from raw icon data # returned by readDIB proc ::ico::getIconAsColorList {w h bpp palette xor and} { # Create initial empty color array that we'll set indices in set colors {} set row {} set empty {} for {set x 0} {$x < $w} {incr x} { lappend row $empty } for {set y 0} {$y < $h} {incr y} { lappend colors $row } set x 0 set y [expr {$h-1}] if {$bpp == 1} { binary scan $xor B* xorBits foreach i [split $xorBits {}] a [split $and {}] { if {$x == $w} { set x 0; incr y -1 } if {$a == 0} { lset colors $y $x [lindex $palette $i] } incr x } } elseif {$bpp == 4} { variable BITS binary scan $xor B* xorBits set i 0 foreach a [split $and {}] { if {$x == $w} { set x 0; incr y -1 } if {$a == 0} { set bits [string range $xorBits $i [expr {$i+3}]] lset colors $y $x [lindex $palette $BITS($bits)] } incr i 4 incr x } } elseif {$bpp == 8} { foreach i [split $xor {}] a [split $and {}] { if {$x == $w} { set x 0; incr y -1 } if {$a == 0} { lset colors $y $x [lindex $palette [scan $i %c]] } incr x } } elseif {$bpp == 16} { variable BITS binary scan $xor b* xorBits set i 0 foreach a [split $and {}] { if {$x == $w} { set x 0; incr y -1 } if {$a == 0} { set b1 [string range $xorBits $i [expr {$i+4}]] set b2 [string range $xorBits [expr {$i+5}] [expr {$i+9}]] set b3 [string range $xorBits [expr {$i+10}] [expr {$i+14}]] lset colors $y $x "#$BITS($b3)$BITS($b2)$BITS($b1)" } incr i 16 incr x } } elseif {$bpp == 24} { foreach {b g r} [split $xor {}] a [split $and {}] { if {$x == $w} { set x 0; incr y -1 } if {$a == 0} { lset colors $y $x [formatColor $r $g $b] } incr x } } elseif {$bpp == 32} { foreach {b g r n} [split $xor {}] a [split $and {}] { if {$x == $w} { set x 0; incr y -1 } if {$a == 0} { lset colors $y $x [formatColor $r $g $b] } incr x } } return $colors } # creates a binary formatted AND mask by reading a list of colors in the decimal list format # and checking for empty colors which designate transparency proc ::ico::getAndMaskFromColors {colors} { set and {} foreach line $colors { set l {} foreach x $line {append l [expr {$x eq ""}]} append l [string repeat 0 [expr {[string length $l] % 32}]] foreach {a b c d e f g h} [split $l {}] { append and [binary format B8 $a$b$c$d$e$f$g$h] } } return $and } # creates a binary formatted XOR mask in the specified depth format from # a list of colors in the decimal list format proc ::ico::getXORFromColors {bpp colors} { set xor {} if {$bpp == 1} { foreach line $colors { foreach {a b c d e f g h} $line { foreach x {a b c d e f g h} { if {[set $x] == ""} {set $x 0} } binary scan $a$b$c$d$e$f$g$h bbbbbbbb h g f e d c b a append xor [binary format b8 $a$b$c$d$e$f$g$h] } } } elseif {$bpp == 4} { foreach line $colors { foreach {a b} $line { if {$a == ""} {set a 0} if {$b == ""} {set b 0} binary scan $a$b b4b4 b a append xor [binary format b8 $a$b] } } } elseif {$bpp == 8} { foreach line $colors { foreach x $line { if {$x == ""} {set x 0} append xor [binary format c $x] } } } elseif {$bpp == 24} { foreach line $colors { foreach x $line { if {![llength $x]} { append xor [binary format ccc 0 0 0] } else { foreach {a b c n} $x { append xor [binary format ccc $c $b $a] } } } } } elseif {$bpp == 32} { foreach line $colors { foreach x $line { if {![llength $x]} { append xor [binary format cccc 0 0 0 0] } else { foreach {a b c n} $x { if {$n == ""} {set n 0} append xor [binary format cccc $c $b $a $n] } } } } } return $xor } # translates a Tk image into a list of colors in the {r g b} format # one element per pixel and {} designating transparent # used by writeIcon when writing from a Tk image proc ::ico::getColorListFromImage {img} { package require Tk set w [image width $img] set h [image height $img] set r {} for {set y [expr $h - 1]} {$y > -1} {incr y -1} { set l {} for {set x 0} {$x < $w} {incr x} { if {[$img transparency get $x $y]} { lappend l {} } else { lappend l [$img get $x $y] } } lappend r $l } return $r } # creates a palette from a list of colors in the decimal list format # a palette consists of 3 values, the number of colors, the palette entry itself, # and the color list transformed to point to palette entries instead of color names # the palette entry itself is stored as 32bpp in "G B R padding" order proc ::ico::getPaletteFromColors {colors} { set palette "\x00\x00\x00\x00" array set tpal {{0 0 0} 0} set new {} set i 1 foreach line $colors { set tline {} foreach x $line { if {$x eq ""} {lappend tline {}; continue} if {![info exists tpal($x)]} { foreach {a b c n} $x { append palette [binary format cccc $c $b $a 0] } set tpal($x) $i incr i } lappend tline $tpal($x) } lappend new $tline } return [list $i $palette $new] } # calculate byte size of an icon. # often passed $w twice because $h is double $w in the binary data proc ::ico::calcSize {w h bpp {offset 0}} { set s [expr {int(($w*$h) * ($bpp/8.0)) \ + ((($w*$h) + ($h*($w%32)))/8) + $offset}] if {$bpp <= 8} { set s [expr {$s + (1 << ($bpp + 2))}] } return $s } # read a Device Independent Bitmap from the current offset, return: # {width height depth palette XOR_mask AND_mask} proc ::ico::readDIB {fh} { binary scan [read $fh 16] x4iix2s w h bpp set h [expr {$h / 2}] seek $fh 24 current set palette [list] if {$bpp == 1 || $bpp == 4 || $bpp == 8} { set colors [read $fh [expr {1 << ($bpp + 2)}]] foreach {b g r x} [split $colors {}] { lappend palette [formatColor $r $g $b] } } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} { # do nothing here } else { return -code error "unsupported color depth: $bpp" } set xor [read $fh [expr {int(($w * $h) * ($bpp / 8.0))}]] set and1 [read $fh [expr {(($w * $h) + ($h * ($w % 32))) / 8}]] set and {} set row [expr {((($w - 1) / 32) * 32 + 32) / 8}] set len [expr {$row * $h}] for {set i 0} {$i < $len} {incr i $row} { binary scan [string range $and1 $i [expr {$i + $row}]] B$w tmp append and $tmp } return [list $w $h $bpp $palette $xor $and] } # read a Device Independent Bitmap from raw data, return: # {width height depth palette XOR_mask AND_mask} proc ::ico::readDIBFromData {data loc} { # Read info from location binary scan $data @${loc}x4iix2s w h bpp set h [expr {$h / 2}] # Move over w/h/bpp info + magic offset to start of DIB set cnt [expr {$loc + 16 + 24}] set palette [list] if {$bpp == 1 || $bpp == 4 || $bpp == 8} { # Could do: [binary scan $data @${cnt}c$len colors] # and iter over colors, but this is more consistent with $fh version set len [expr {1 << ($bpp + 2)}] set colors [string range $data $cnt [expr {$cnt + $len - 1}]] foreach {b g r x} [split $colors {}] { lappend palette [formatColor $r $g $b] } incr cnt $len } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} { # do nothing here } else { return -code error "unsupported color depth: $bpp" } # Use -1 to account for string range inclusiveness set end [expr {$cnt + int(($w * $h) * ($bpp / 8.0)) - 1}] set xor [string range $data $cnt $end] set and1 [string range $data [expr {$end + 1}] \ [expr {$end + ((($w * $h) + ($h * ($w % 32))) / 8) - 1}]] set and {} set row [expr {((($w - 1) / 32) * 32 + 32) / 8}] set len [expr {$row * $h}] for {set i 0} {$i < $len} {incr i $row} { # Has to be decoded by row, in order binary scan [string range $and1 $i [expr {$i + $row}]] B$w tmp append and $tmp } return [list $w $h $bpp $palette $xor $and] } proc ::ico::getIconListICO {file} { set fh [open $file r] fconfigure $fh -eofchar {} -encoding binary -translation lf # both words must be read to keep in sync with later reads if {"[getword $fh] [getword $fh]" ne "0 1"} { return -code error "not an icon file" } set num [getword $fh] set r {} for {set i 0} {$i < $num} {incr i} { set info {} lappend info [scan [read $fh 1] %c] [scan [read $fh 1] %c] set bpp [scan [read $fh 1] %c] if {$bpp == 0} { set orig [tell $fh] seek $fh 9 current seek $fh [expr {[getdword $fh] + 14}] start lappend info [getword $fh] seek $fh $orig start } else { lappend info [expr {int(sqrt($bpp))}] } lappend r $info seek $fh 13 current } close $fh return $r } proc ::ico::getIconListICODATA {data} { if {[binary scan $data sss h1 h2 num] != 3 || $h1 != 0 || $h2 != 1} { return -code error "not icon data" } set r {} set cnt 6 for {set i 0} {$i < $num} {incr i} { if {[binary scan $data @${cnt}ccc w h bpp] != 3} { return -code error "error decoding icon data" } incr cnt 3 set info [list $w $h] if {$bpp == 0} { set off [expr {$cnt + 9}] binary scan $data @${off}i off incr off 14 binary scan $data @${off}s bpp lappend info $bpp } else { lappend info [expr {int(sqrt($bpp))}] } lappend r $info incr cnt 13 } return $r } proc ::ico::getIconListBMP {file} { set fh [open $file] if {[read $fh 2] != "BM"} { close $fh; return -code error "not a BMP file" } seek $fh 14 start binary scan [read $fh 16] x4iix2s w h bpp close $fh return [list $w $h $bpp] } proc ::ico::getIconListEXE {file} { variable ICONS set file [file normalize $file] set cnt [SearchForIcos $file] set icons [list] for {set i 0} {$i <= $cnt} {incr i} { lappend icons $ICONS($file,$i,data) } return $icons } # returns an icon in the form: # {width height depth palette xor_mask and_mask} proc ::ico::getRawIconDataICO {file index} { set fh [open $file r] fconfigure $fh -eofchar {} -encoding binary -translation lf # both words must be read to keep in sync with later reads if {"[getword $fh] [getword $fh]" ne "0 1"} { close $fh return -code error "not an icon file" } if {$index < 0 || $index >= [getword $fh]} { return -code error "index out of range" } seek $fh [expr {(16 * $index) + 12}] current seek $fh [getdword $fh] start # readDIB returns: {w h bpp palette xor and} set dib [readDIB $fh] close $fh return $dib } proc ::ico::getRawIconDataICODATA {data index} { if {[binary scan $data sss h1 h2 num] != 3 || $h1 != 0 || $h2 != 1} { return -code error "not icon data" } if {$index < 0 || $index >= $num} { return -code error "index out of range: must be between 0 and $num" } # Move to ico location set cnt [expr {6 + (16 * $index) + 12}] binary scan $data @${cnt}i loc # readDIB returns: {w h bpp palette xor and} set dib [readDIBFromData $data $loc] return $dib } # returns an icon in the form: # {width height depth palette xor_mask and_mask} proc ::ico::getRawIconDataBMP {file {index 0}} { if {$index != 0} {return -code error "index out of range"} set fh [open $file] if {[read $fh 2] != "BM"} { close $fh; return -code error "not a BMP file" } seek $fh 14 start binary scan [read $fh 16] x4iix2s w h bpp seek $fh 24 current set palette [list] if {$bpp == 1 || $bpp == 4 || $bpp == 8} { set colors [read $fh [expr {1 << ($bpp + 2)}]] foreach {b g r x} [split $colors {}] { lappend palette [formatColor $r $g $b] } } elseif {$bpp == 16 || $bpp == 24 || $bpp == 32} { # do nothing here } else { return -code error "unsupported color depth: $bpp" } set xor [read $fh [expr {int(($w * $h) * ($bpp / 8.0))}]] set and [string repeat 0 [expr {$w * $h}]] close $fh return [list $w $h $bpp $palette $xor $and] } # returns an icon in the form: # {width height depth palette xor_mask and_mask} proc ::ico::getRawIconDataEXE {file index} { variable ICONS set file [file normalize $file] set cnt [SearchForIcos $file $index] if {$cnt < $index} { return -code error "index out of range" } set fh [open $file] fconfigure $fh -eofchar {} -encoding binary -translation lf seek $fh $ICONS($file,$index) start # readDIB returns: {w h bpp palette xor and} set dib [readDIB $fh] close $fh return $dib } proc ::ico::writeIconICO {file index w h bpp palette xor and} { if {![file exists $file]} { set fh [open $file w+] fconfigure $fh -eofchar {} -encoding binary -translation lf bputs $fh sss 0 1 0 seek $fh 0 start } else { set fh [open $file r+] fconfigure $fh -eofchar {} -encoding binary -translation lf } if {[file size $file] > 4 && "[getword $fh] [getword $fh]" ne "0 1"} { close $fh return -code error "not an icon file" } set num [getword $fh] if {$index eq "end"} { set index $num } if {$index < 0 || $index > $num} { close $fh return -code error "index out of range" } set colors 0 if {$bpp <= 8} {set colors [expr {1 << $bpp}]} set size [expr {[string length $palette] + [string length $xor] + [string length $and]}] # if we are adding a new icon at the end if {$index == $num} { # increment the icon count seek $fh -2 current bputs $fh s [expr {$num + 1}] # save all the data past the icon dir entries seek $fh [expr {$num * 16}] current set olddata [read $fh] # increment all the offsets in the existing dir entries by 16 to account for our new entry set cur 0 while {$cur < $num} { seek $fh [expr {($cur * 16) + 18}] start set toff [getdword $fh] seek $fh -4 current bputs $fh i [expr {$toff + 16}] incr cur } # insert new icon dir entry bputs $fh ccccss $w $h $colors 0 0 $bpp bputs $fh ii [expr {$size + 40}] [expr {[string length $olddata] + [tell $fh] + 8}] # put all the icon data back puts -nonewline $fh $olddata # put our new icon at the end bputs $fh iiissiiiiii 40 $w [expr {$h * 2}] 1 $bpp 0 $size 0 0 0 0 puts -nonewline $fh $palette puts -nonewline $fh $xor puts -nonewline $fh $and } else { # we are overwriting an icon - not necesarily the same size # get existing icon offset and length seek $fh [expr {($index * 16) + 8}] current set len [getdword $fh] set offset [getdword $fh] # adjust offset in existing icon dir entries higher than our new icon to account # for new icon length set cur [expr {$index + 1}] while {$cur < $num} { seek $fh [expr {($cur * 16) + 18}] start set toff [getdword $fh] seek $fh -4 current bputs $fh i [expr {$toff + (($size + 40) - $len)}] incr cur } # save all data after new icon seek $fh [expr {$offset + $len}] start set olddata [read $fh] # overwrite icon dir entry seek $fh [expr {($index * 16) + 6}] start bputs $fh ccccssi $w $h $colors 0 0 $bpp [expr {$size + 40}] # insert new icon and saved data seek $fh $offset start bputs $fh iiissiiiiii 40 $w [expr {$h * 2}] 1 $bpp 0 $size 0 0 0 0 puts -nonewline $fh $palette puts -nonewline $fh $xor puts -nonewline $fh $and puts -nonewline $fh $olddata } close $fh } proc ::ico::writeIconICODATA {file index w h bpp palette xor and} { if {$index != 0} {return -code error "index out of range"} upvar 2 [file tail $file] data set data [binary format sss 0 1 1] set colors 0 if {$bpp <= 8} {set colors [expr {1 << $bpp}]} set size [expr {[string length $palette] + [string length $xor] + [string length $and]}] append data [binary format ccccssii $w $h $colors 0 0 $bpp [expr {$size + 40}] 22] append data [binary format iiissiiiiii 40 $w [expr {$h * 2}] 1 $bpp 0 $size 0 0 0 0] append data $palette $xor $and } proc ::ico::writeIconBMP {file index w h bpp palette xor and} { if {$index != 0} {return -code error "index out of range"} set fh [open $file w+] fconfigure $fh -eofchar {} -encoding binary -translation lf set size [expr {[string length $palette] + [string length $xor]}] # bitmap header: magic, file size, reserved, reserved, offset of bitmap data bputs $fh a2issi BM [expr {14 + 40 + $size}] 0 0 54 bputs $fh iiissiiiiii 40 $w $h 1 $bpp 0 $size 0 0 0 0 puts -nonewline $fh $palette$xor close $fh } proc ::ico::writeIconEXE {file index w h bpp palette xor and} { variable ICONS set file [file normalize $file] set cnt [SearchForIcos $file $index] if {$index eq "end"} {set index $cnt} if {$cnt < $index} { return -code error "index out of range" } if {[list $w $h $bpp] != $ICONS($file,$index,data)} { return -code error "icon format differs from original" } set fh [open $file r+] fconfigure $fh -eofchar {} -encoding binary -translation lf seek $fh [expr {$ICONS($file,$index) + 40}] start puts -nonewline $fh $palette$xor$and close $fh } proc ::ico::SearchForIcos {file {index -1}} { variable ICONS ; # stores icos offsets by index, and [list w h bpp] if {[info exists ICONS($file,$index)]} { return $ICONS($file,$index) } set fh [open $file] fconfigure $fh -eofchar {} -encoding binary -translation lf if {[read $fh 2] ne "MZ"} { close $fh return -code error "unknown file format" } seek $fh 60 start seek $fh [getword $fh] start set sig [read $fh 4] seek $fh -4 current if {$sig eq "PE\000\000"} { return [SearchForIcosPE $fh $file $index] } elseif {[string match NE* $sig]} { return [SearchForIcosNE $fh $file $index] } else { return -code error "unknown file format" } } # parse the resource table of 16 bit windows files for icons proc ::ico::SearchForIcosNE {fh file index} { variable ICONS ; # stores icos offsets by index, and [list w h bpp] set idx -1 ; # index of icos found seek $fh 36 current seek $fh [expr {[getword $fh] - 38}] current set base [tell $fh] set shift [expr {int(pow(2, [getushort $fh]))}] while {[set type [expr {[getushort $fh] & 0x7fff}]] != 0} { set num [getushort $fh] if {$type != 3} { seek $fh [expr {($num * 12) + 4}] current continue } seek $fh 4 current for {set i 0} {$i < $num} {incr i} { incr idx set ICONS($file,$idx) [expr {[getushort $fh] * $shift}] seek $fh 10 current set cur [tell $fh] seek $fh $ICONS($file,$idx) start binary scan [read $fh 16] x4iix2s w h bpp set ICONS($file,$idx,data) [list $w [expr {$h / 2}] $bpp] seek $fh $cur start } close $fh return $idx } close $fh return -1 } # parse the resource tree of 32 bit windows files for icons proc ::ico::SearchForIcosPE {fh file index} { variable ICONS ; # stores icos offsets by index, and [list w h bpp] set idx -1 ; # index of icos found # find the .rsrc section by reading the coff header binary scan [read $fh 24] x6sx12s sections headersize seek $fh $headersize current for {set i 0} {$i < $sections} {incr i} { binary scan [read $fh 40] a8x4ix4i type baserva base if {[string match .rsrc* $type]} {break} } # no resource section found = no icons if {![string match .rsrc* $type]} { close $fh return -1 } seek $fh $base start seek $fh 12 current set entries [expr {[getushort $fh] + [getushort $fh]}] for {set i 0} {$i < $entries} {incr i} { set name [getulong $fh] set offset [expr {[getulong $fh] & 0x7fffffff}] if {$name != 3} {continue} seek $fh [expr {$base + $offset + 12}] start set entries2 [expr {[getushort $fh] + [getushort $fh]}] for {set i2 0} {$i2 < $entries2} {incr i2} { seek $fh 4 current set offset [expr {[getulong $fh] & 0x7fffffff}] set cur2 [tell $fh] seek $fh [expr {$offset + $base + 12}] start set entries3 [expr {[getushort $fh] + [getushort $fh]}] for {set i3 0} {$i3 < $entries3} {incr i3} { seek $fh 4 current set offset [expr {[getulong $fh] & 0x7fffffff}] set cur3 [tell $fh] seek $fh [expr {$offset + $base}] start set rva [getulong $fh] incr idx set ICONS($file,$idx) [expr {$rva - $baserva + $base}] seek $fh $ICONS($file,$idx) start binary scan [read $fh 16] x4iix2s w h bpp set ICONS($file,$idx,data) [list $w [expr {$h / 2}] $bpp] seek $fh $cur3 start } seek $fh $cur2 start } close $fh return $idx } close $fh return -1 } interp alias {} ::ico::getIconListDLL {} ::ico::getIconListEXE interp alias {} ::ico::getRawIconDataDLL {} ::ico::getRawIconDataEXE interp alias {} ::ico::writeIconDLL {} ::ico::writeIconEXE interp alias {} ::ico::getIconListICL {} ::ico::getIconListEXE interp alias {} ::ico::getRawIconDataICL {} ::ico::getRawIconDataEXE interp alias {} ::ico::writeIconICL {} ::ico::writeIconEXE proc ::ico::showaux {files} { if {[llength $files]} { set file [lindex $files 0] Show $f update after 50 [list ::ico::showaux [lrange $files 1 end]] } } # Application level command: Find icons in a file and show them. proc ::ico::Show {file args} { package require BWidget set parent . parseOpts {type parent} $args if {![info exists type]} { # $type wasn't specified - get it from the extension set type [fileext $file] } set file [file normalize $file] set icos [getIconList $file -type $type] set wname [string map {. _ : _} $file] if {$parent eq "."} { set w ""} else { set w $parent } set mf $w.mainsw if {![winfo exists $mf]} { set sw [ScrolledWindow $mf] set sf [ScrollableFrame $mf.sf -constrainedwidth 1] $sw setwidget $sf pack $sw -fill both -expand 1 grid columnconfigure [$mf.sf getframe] 0 -weight 1 } set mf [$mf.sf getframe] set lf $mf.f$wname if {[winfo exists $lf]} { destroy $lf } if {![llength $icos]} { label $lf -text "No icons in '$file'" -anchor w grid $lf -sticky ew } else { labelframe $lf -text "[llength $icos] Icons in '$file'" grid $lf -sticky news set sw [ScrolledWindow $lf.sw$wname] set height 48 set fh [expr {[font metrics [$lf cget -font] -linespace] + 4}] set sf [ScrollableFrame $lf.sf$wname -constrainedheight 1 \ -height [expr {$height + $fh}]] $sw setwidget $sf set sf [$sf getframe] pack $sw -fill both -expand 1 set col 0 for {set x 0} {$x < [llength $icos]} {incr x} { # catch in case theres any icons with unsupported color if {[catch {getIcon $file $x -type $type} img]} { set txt "ERROR: $img" set lbl [label $sf.lbl$wname-$x -anchor w -text $txt] grid $lbl -sticky s -row 0 -column [incr col] } else { set txt [eval {format "$x: %sx%s %sbpp"} [lindex $icos $x]] set lbl [label $sf.lbl$wname-$x -anchor w -text $txt \ -compound top -image $img] if {[image height $img] > $height} { set height [image height $img] $lf.sf$wname configure -height [expr {$height + $fh}] } grid $lbl -sticky s -row 0 -column [incr col] } update idletasks } } grid rowconfigure $parent 0 -weight 1 grid columnconfigure $parent 0 -weight 1 } package provide ico 0.3.1 tcltk2/inst/tklibs/ico1.0/ChangeLog0000644000176000001440000001062212215417550016520 0ustar ripleyusers2009-01-21 Andreas Kupries * * Released and tagged Tklib 0.5 ======================== * 2008-03-12 Jeff Hobbs * ico.tcl (::ico::writeIconICODATA, ::ico::writeIconICO): correct the * pkgIndex.tcl: icon table header height info (was doubling), update version to 1.0.3. 2007-5-17 Aaron Faupell * ico.tcl: fixed problem with reading BMPs and updated getFileIcon to search for additional icons (read CLSID) * ico.man: updated example and added verbage to getFileIcon 2007-02-23 Jeff Hobbs * ico0.tcl (::ico::readDIBFromData): correct row calc for edge case. Bump version to 0.3.1 * ico.tcl (::ico::getFileIcon): fixed for better overall support. [Bug 1660234] (Griffiths). Bumped version to 1.0.2 2006-12-14 Aaron Faupell * ico.tcl: fixed problem in EXEtoICO and incremented version to 1.0.1 2006-12-12 Jeff Hobbs * ico.tcl (::ico::getFileIcon): fixed missing close ] 2006-08-04 Jeff Hobbs * ico0.tcl: added back ico 0.3 for compatibility * pkgIndex.tcl: note both 0.3 and 1.0 exist 2006-07-18 Andreas Kupries * ico.man: Fixed syntax problems in the manpage. 2006-07-11 Aaron Faupell * ico.tcl: many changes to add support for icon groups * ico.man: many changes to reflect new commands and usage **** update to v1.0 POTENTIAL INCOMPATIBILITY **** 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-28 Aaron Faupell * ico.tcl fixed padding algorithm to handle icons >48px 2005-05-27 Jeff Hobbs * ico.tcl (::ico::Show): handle >48px icons by resizing the frame. Currently >48px icons are not decoded properly by ico though. 2004-08-20 Aaron Faupell * ico.tcl bugfix in writeIconEXE, called SearchForIcos with wrong args 2004-08-20 Aaron Faupell * ico.tcl: added writing of BMP and ICODATA types. 2004-08-18 Aaron Faupell * ico.tcl: added support for reading from BMP files Modified transparentColor to work on pixel list also. * ico.man: updated with the new functionality 2004-08-18 Andreas Kupries * ico.man: Fixed problems with formatting of ico manpage. 2004-08-17 Aaron Faupell * ico.tcl: CheckEXE removed and replaced by new SearchForIcos which calls SearchForIcosNE or SearchForIcosPE which atually parse the window resource tables resulting in a nice speed improvement over the old linear search. Also corrected all usage of fconfigure. 2004-07-27 Aaron Faupell * ico.tcl: undocumented windows feature: if the first palette entry isnt black, the transparent background displays in odd colors. fixed getPaletteFromColors to initialize palette with black. changed header writing to use 0 for planes to be consistant with windows. 2004-07-26 Aaron Faupell * ico.tcl: renamed some of the private API to be more descriptive. bugfix in writeIcon and translateColors and CopyIcon. simplified writeIconEXE. 2004-07-26 Andreas Kupries * ico.man: Reworked the documentation a bit (fixed bugs, reordered stuff a bit). 2004-07-26 Jeff Hobbs * pkgIndex.tcl, ico.man, ico.tcl: add -type ICODATA as a way pass ICO data instead of a filename. Currently supports read, not write. Made 'package require Tk' only get called as necessary for the api. Code cleanup, update to v0.3. * ico.man (new): * ico.tcl: revamp of API from Aaron, more public APIs. 2004-07-24 Jeff Hobbs * ico.tcl (::ico::getIconImageFromData): add call to retrive icon image from ICO info as data (not "official", may change). 2004-07-22 Jeff Hobbs * ico.tcl: added to tklib as v0.2. Primary usage is like so: set file bin/wish.exe set icos [::ico::getIcons $file] set img [::ico::getIconImage $file -index 1] tcltk2/inst/tklibs/ico1.0/ico.man0000644000176000001440000001647012215417550016224 0ustar ripleyusers[comment {-*- tcl -*- doctools manpage}] [manpage_begin ico n 1.0] [moddesc {Windows ICO handling}] [titledesc {Reading and writing windows icons}] [require Tcl 8.4] [require ico [opt 1.0]] [description] This package provides functions for reading and writing Windows icons from ICO, EXE, DLL, ICL, and BMP files. As used in this module an icon is a visual representation of an object. An icon consists of one or more images usually with varying resolution and color depth. Each icon and image has a resource identifier which may be a text string or a positive integer value. Most commands use this identifier to specify which icon or image to operate on. [section API] [list_begin definitions] [call [cmd ::ico::icons] [arg file] [opt "[arg option] [arg value]..."]] Returns a list of icons found in [arg file] where each element is the name or numeric ID. Recognizes the following options: [list_begin opt] [opt_def -type fileFormat] [list_end] [nl] [call [cmd ::ico::iconMembers] [arg file] [arg name] [opt "[arg option] [arg value]..."]] Returns a list of images that make up the icon with ID [arg name]. Each element is itself a sublist in the format {name width height bpp}. Recognizes the following options: [list_begin opt] [opt_def -type fileFormat] [list_end] [nl] [call [cmd ::ico::getIcon] [arg file] [arg name] [opt "[arg option] [arg value]..."]] Extracts the icon with ID [arg name] from [arg file]. The default [option -format] is [const image] which will return the name of a Tk image containing the icon. The resolution and color depth are selected with the [opt -res], [opt -bpp], and [opt -exact] options. If -exact is specified and there is no exact match, an error is thrown. Optionally [option -image] may be used to specify the name of the Tk image that is created. If [option -format] is [const colors] then a list of color names in the #RRGGBB format is returned. Each list element is a horizontal row. Each horizontal row contains a list of colors for all the pixels in that row from left to right. If [option -format] is [const name] then the resource name of the image chosen is returned. This is useful for calling writeIcon or getIconByName. Recognizes the following [arg option]s. [list_begin opt] [opt_def -type fileFormat] [opt_def -format value] [opt_def -image value] [opt_def -res value] [opt_def -bpp value] [opt_def -exact value] [list_end] [nl] [call [cmd ::ico::getIconByName] [arg file] [arg name] [opt "[arg option] [arg value]..."]] Extracts the image with ID [arg name] from [arg file]. This name should be the name of a specific image as returned by [cmd ::ico::iconMembers], not an icon name returned from [cmd ::ico::icons]. If there is no matching resource ID in [arg file] an error is thrown. Recognizes the following options: [list_begin opt] [opt_def -type fileFormat] [opt_def -format value] [list_end] [nl] [call [cmd ::ico::getFileIcon] [arg file] [opt "[arg option] [arg value]..."]] This command is only functional when running under Windows. It reads the Windows registry to determine the display icon for [arg file] as it would appear in Explorer or similar. [arg file] does not need to exist and may also be specified as a file extension with a leading dot. If [arg file] is a directory or you specify the special name [const Folder] then the icon representing a folder is returned. This command takes the same arguments and usage as [cmd getIcon]: [list_begin opt] [opt_def -format value] [opt_def -image value] [opt_def -res value] [opt_def -bpp value] [opt_def -exact value] [list_end] [nl] [call [cmd ::ico::writeIcon] [arg file] [arg name] [arg depth] [arg data] [opt "[arg option] [arg value]..."]] Writes an image to [arg file]. [arg name] is the resource identifier of the image in [arg file] to write. When writing to an EXE, DLL, or ICL file you may only overwrite existing icons with an icon of the same dimensions and color depth. No icons may be added to these file types. [nl] When writing to BMP the name is ignored as this type can contain only one image. This means if the file already existed it is completely overwritten. [nl] When writing to an ICO or ICODATA file if the name specified does not exist then an image is appended and will be named the next in sequence (the specified name is ignored). Images in ICO and ICODATA files may be overwritten with differing dimensions or color depths. Note that you will get strange results when displaying icons if you fail to change every image which makes up a given icon. [list_begin arg] [arg_def integer depth in] This argument must have a value of [const 1], [const 4], [const 8], [const 24], or [const 32]. If [arg data] has more colors than the color depth allows an error will be generated. [arg_def options data in] This argument is either a list of colors in the format returned by [cmd {::ico::getIcon -format colors}] or the name of a Tk image. [list_end] [nl] Recognizes the following [arg option]s. [list_begin opt] [opt_def -type fileFormat] [list_end] [nl] [call [cmd ::ico::copyIcon] [arg file] [arg index] [arg file2] [arg index2] [opt "[arg option] [arg value]..."]] Copies the icon at [arg index] in [arg file] to [arg index2] in [arg file2]. [list_begin opt] [opt_def -fromtype fileFormat] [opt_def -totype fileFormat] [list_end] [nl] [call [cmd ::ico::EXEtoICO] [arg file] [opt dir]] Extracts all icons from the executable [arg file] to ICO files placed in [arg dir]. [opt dir] defaults to the directory [arg file] is located in. Icon files will be named in the form [arg file]-ID.ico where ID is the icon resource identifier. [list_begin opt] [opt_def -type fileFormat] [list_end] [nl] [call [cmd ::ico::clearCache] [opt file]] The [cmd ::ico::getIconList] command caches icon offsets inside EXE, DLL, ICL, and ICO files in order to speed up extraction. This command clears that cache for the specific [opt file] or all files. [call [cmd ::ico::transparentColor] [arg image] [arg color]] If [arg image] is a single word it is assumed to be the name of a Tk image. All pixels matching [arg color] in the [arg image] will be set transparent. Alternatively, [arg image] may be a color list in which case a modified list is returned. [call [cmd ::ico::Show] [arg file] [opt "[arg option] [arg value]..."]] Application level command which displays a window showing all the icons in [arg file] and their name. [list_begin opt] [opt_def -type fileFormat] [opt_def -parent pathName] [list_end] [list_end] [section EXAMPLE] [example { button .explore -image [::ico::getIcon explorer.exe 0 -name explore -res 16 -bpp 8] set i [lsearch -inline [::ico::iconMembers tclkit.exe 0] {* 32 32 8}] set colorlist [::ico::getIconByName tclkit.exe [lindex $i 0] -format colors] }] [section LIMITATIONS] Icons may not be added or removed from file types other than ICO. Icons in these files may only be replaced with icons of the same dimensions and color depth. [para] Icons of 8bpp or lower must include black in the pallete, this means if your icon does not have black in it, you will need to leave a color free so that it may be included by writeIcon. [para] There is currently no way to read alpha channel information from 32bpp icons. [para] Tk images do not have an alpha channel so the only way to write a true 32bpp icon is from a color list. writing a 32bpp icon from a Tkimage is identical to writing a 24bpp icon. [keywords entry icon ico exe dll] [manpage_end] tcltk2/inst/tklibs/autoscroll1.1/0000755000176000001440000000000012445051436016365 5ustar ripleyuserstcltk2/inst/tklibs/autoscroll1.1/autoscroll.tcl0000644000176000001440000001571012215417550021262 0ustar ripleyusers# 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.tcl0000644000176000001440000000114312215417550020637 0ustar ripleyusers# 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/example.tcl0000644000176000001440000000036112215417550020522 0ustar ripleyuserssource ./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/autoscroll1.1/autoscroll.man0000644000176000001440000000367312215417550021260 0ustar ripleyusers[comment {-*- tcl -*- doctools manpage}] [manpage_begin autoscroll n 1.1] [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 }] [keywords scroll scrollbar] [manpage_end] tcltk2/inst/tklibs/autoscroll1.1/ChangeLog0000644000176000001440000000216112215417550020135 0ustar ripleyusers2009-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/ctext3.2/0000755000176000001440000000000012445051436015330 5ustar ripleyuserstcltk2/inst/tklibs/ctext3.2/TODO0000644000176000001440000000040012215417550016010 0ustar ripleyusersMake the flags that ctext adds have Class and resource names. Also make .t config return those resource/class names. I suspect that I could do this by making each value for a flag a list, but this needs proper planning before I go coding in the unknown. tcltk2/inst/tklibs/ctext3.2/BUGS0000644000176000001440000000166312215417550016017 0ustar ripleyusers# RCS: @(#) $Id: BUGS,v 1.3 2005/04/07 02:33:30 andreas_kupries Exp $ The linemap and text widget can get into a voodoo dance of geometry-management madness. This can occur with lines that wrap and cause the linemap to be able to continue a line. When the wrap occurs the linemap changes, because the width of the linemap is altered, so the text and linemap do idle size changes until the user goes up or down to avoid the problem. Resource classes are not handled with the configure subcommand. I don't like having to create a temporary widget to get defaults for colors. We might be able to just extract the defaults, by removing the colors flags from the $args and then reconfiguring the widget to use them as normal. This would remove ctext_temp or whatever I called that. With some fonts; bitmaps don't display properly on the same line. The size of the bitmap seems to be the issue. This seems to be a bug with the text widget.tcltk2/inst/tklibs/ctext3.2/ctext.man0000644000176000001440000002037012215417550017154 0ustar ripleyusers[comment {# RCS: @(#) $Id: ctext.man,v 1.6 2008/08/20 03:45:58 georgeps Exp $}] [comment {-*- tcl -*- doctools manpage}] [manpage_begin ctext n 3.2] [copyright {George Peter Staplin }] [moddesc {Ctext a text widget with highlighting support}] [titledesc {Ctext a text widget with highlighting support}] [require Tk] [require ctext [opt 3.2]] [description] The [package ctext] package provides the ctext widget which is an enhanced text widget with support for configurable syntax highlighting and some extra commands. [para] Ctext overloads the text widget and provides new commands, named [method highlight], [method copy], [method paste],[method cut], [method append], and [method edit]. It also provides several commands that allow you to define classes. Each class corresponds to a tag in the widget. [section COMMANDS] [list_begin definitions] [call [cmd ctext] [arg pathName] [opt [arg options]]] Creates and configures a ctext widget. [list_end] [section {HIGHLIGHTING}] Highlighting is controlled with text widget tags, that are called highlight classes. The [arg class] is a tag name and can be configured like any text widget tag. Four types of highlight classes are supported. All highlight classes are automatically used by the [method highlight] method of the widget. [list_begin definitions] [call [cmd ::ctext::addHighlightClass] [arg pathName] [arg class] [arg color] [arg keywordlist]] Add a highlighting class [arg class] to the ctext widget [arg pathName]. The highligthing will be done with the color [arg color]. All words in the [arg keywordlist] will be highlighted. [example { # highlight some tcl keywords ::ctext::addHighlightClass .t tclkeywords red [list set info interp uplevel upvar]] }] [call [cmd ::ctext::addHighlightClassWithOnlyCharStart] [arg pathName] [arg class] [arg color] [arg char]] Add a highlighting class [arg class] to the ctext widget [arg pathName]. The highligthing will be done with the color [arg color]. All words starting with [arg char] will be highlighted. [example { ::ctext::addHighlightClassWithOnlyCharStart .t vars blue \$ }] [call [cmd ::ctext::addHighlightClassForSpecialChars] [arg pathName] [arg class] [arg color] [arg charstring]] Add a highlighting class [arg class] to the ctext widget [arg pathName]. The highligthing will be done with the color [arg color]. All chars in [arg charstring] will be highlighted. [call [cmd ::ctext::addHighlightClassForRegexp] [arg pathName] [arg class] [arg color] [arg pattern]] Add a highlighting class [arg class] to the ctext widget [arg pathName]. The highligthing will be done with the color [arg color]. All text parts matching the regexp [arg pattern] will be highligthed. [call [cmd ::ctext::clearHighlightClasses] [arg pathName]] Remove all highlight classes from the widget [arg pathName]. [call [cmd ::ctext::getHighlightClasses] [arg pathName]] List all highlight classes for the widget [arg pathName]. [call [cmd ::ctext::deleteHighlightClass] [arg pathName] [arg class]] Delete the highlight class [arg class] from the widget [arg pathName] [call [cmd ::ctext::enableComments] [arg enable]] Enable C comment highlighting. The [arg class] for c-style comments is [const _cComment]. The C comment highlighting is disabled by default. [call [cmd ::ctext::disableComments] [arg enable]] Disable C comment highlighting. [list_end] [section {WIDGET COMMANDS}] Each ctext widget created with the above command supports the following commands and options in addition to the standard text widget commands and options. [list_begin definitions] [call [arg pathName] [method highlight] [arg startIndex] [arg endIndex]] Highlight the text between [arg startIndex] and [arg endIndex]. [call [arg pathName] [method fastdelete] [arg index1] [opt [arg index2]]] Delete text range without updating the highlighting. Arguments are identical to the [arg pathName] [method delete] command inherited from the standard text widget. [call [arg pathName] [method fastinsert] ] Insert text without updating the highlighting. Arguments are identical to the [arg pathName] [method insert] command inherited from the standard text widget. [call [arg pathName] [method copy] ] Call [cmd tk_textCopy] for the ctext instance. [call [arg pathName] [method cut] ] Call [cmd tk_textCut] for the ctext instance. [call [arg pathName] [method paste] ] Call [cmd tk_textPaste] for the ctext instance. [call [arg pathName] [method append] ] Append the current selection to the clipboard. [call [arg pathName] [method configure] [arg option] [arg value] [opt ...]] Set the options for the ctext widget. Each option name must be followed the new value. [list_end] [section {WIDGET OPTIONS}] [list_begin tkoption] [tkoption_def -linemap "" ""] Creates (-linemap 1) or deletes (-linemap 0) a line number list on the left of the widget. The default is to have a linemap displayed. [tkoption_def -linemapfg "" ""] Changes the foreground of the linemap. The default is the same color as the main text widget. [tkoption_def -linemapbg "" ""] Changes the background of the linemap. The default is the same color as the main text widget. [tkoption_def -linemap_select_fg "" ""] Changes the selected line foreground. The default is black. [tkoption_def -linemap_select_bg "" ""] Changes the selected line background. The default is yellow. [tkoption_def -linemap_mark_command "" ""] Calls a procedure or command with the [arg pathName] of the ctext window, the [arg type] which is either [const marked] or [const unmarked], and finally the line number selected. The proc prototype is: [example { proc linemark_cmd {win type line}. }] See also ctext_test_interactive.tcl [tkoption_def -highlight "" ""] Takes a boolean value which defines whether or not to highlight text which is inserted or deleted. The default is 1. [tkoption_def -linemap_markable "" ""] Takes a boolean value which specifies whether or not lines in the linemap are markable with the mouse. The default is 1. [list_end] [section EXAMPLE] [example { package require Tk package require ctext proc main {} { pack [frame .f] -fill both -expand 1 pack [scrollbar .f.s -command {.f.t yview}] -side right -fill y pack [ctext .f.t -bg black -fg white -insertbackground yellow \ -yscrollcommand {.f.s set}] -fill both -expand 1 ctext::addHighlightClass .f.t widgets purple \ [list ctext button label text frame toplevel \ scrollbar checkbutton canvas listbox menu menubar menubutton \ radiobutton scale entry message tk_chooseDir tk_getSaveFile \ tk_getOpenFile tk_chooseColor tk_optionMenu] ctext::addHighlightClass .f.t flags orange \ [list -text -command -yscrollcommand \ -xscrollcommand -background -foreground -fg -bg \ -highlightbackground -y -x -highlightcolor -relief -width \ -height -wrap -font -fill -side -outline -style -insertwidth \ -textvariable -activebackground -activeforeground -insertbackground \ -anchor -orient -troughcolor -nonewline -expand -type -message \ -title -offset -in -after -yscroll -xscroll -forward -regexp -count \ -exact -padx -ipadx -filetypes -all -from -to -label -value -variable \ -regexp -backwards -forwards -bd -pady -ipady -state -row -column \ -cursor -highlightcolors -linemap -menu -tearoff -displayof -cursor \ -underline -tags -tag] ctext::addHighlightClass .f.t stackControl red \ {proc uplevel namespace while for foreach if else} ctext::addHighlightClassWithOnlyCharStart .f.t vars mediumspringgreen "\$" ctext::addHighlightClass .f.t variable_funcs gold {set global variable unset} ctext::addHighlightClassForSpecialChars .f.t brackets green {[]{}} ctext::addHighlightClassForRegexp .f.t paths lightblue {\.[a-zA-Z0-9\_\-]+} ctext::addHighlightClassForRegexp .f.t comments khaki {#[^\n\r]*} .f.t fastinsert end [info body main] pack [frame .f1] -fill x .f.t highlight 1.0 end pack [button .f1.exit -text Exit -command exit] -side left pack [entry .e] -side bottom -fill x .e insert end "ctext::deleteHighlightClass .f.t " bind .e {eval [.e get]} } main }] Further examples are in the source package for ctext. [section THANKS] Kevin Kenny, Neil Madden, Jeffrey Hobbs, Richard Suchenwirth, Johan Bengtsson, Mac Cody, Gnther, Andreas Sievers, and Michael Schlenker. [see_also text re_syntax] [keywords text widget "syntax highlighting"] [manpage_end] tcltk2/inst/tklibs/ctext3.2/pkgIndex.tcl0000644000176000001440000000010412215417550017576 0ustar ripleyuserspackage ifneeded ctext 3.2 [list source [file join $dir ctext.tcl]] tcltk2/inst/tklibs/ctext3.2/example.tcl0000755000176000001440000000671612215417550017502 0ustar ripleyusers#!/bin/sh # the next line restarts using wish \ exec wish "$0" ${1+"$@"} #set tcl_traceExec 1 proc main {} { source ./ctext.tcl pack [frame .f] -fill both -expand 1 #Of course this could be cscrollbar instead, but it's not as common. pack [scrollbar .f.s -command {.f.t yview}] -side right -fill y #Dark colors pack [ctext .f.t -linemap 1 -bg black -fg white -insertbackground yellow \ -yscrollcommand {.f.s set}] -fill both -expand 1 ctext::addHighlightClass .f.t widgets purple [list obutton button label text frame toplevel \ cscrollbar scrollbar checkbutton canvas listbox menu menubar menubutton \ radiobutton scale entry message tk_chooseDir tk_getSaveFile \ tk_getOpenFile tk_chooseColor tk_optionMenu] ctext::addHighlightClass .f.t flags orange [list -text -command -yscrollcommand \ -xscrollcommand -background -foreground -fg -bg \ -highlightbackground -y -x -highlightcolor -relief -width \ -height -wrap -font -fill -side -outline -style -insertwidth \ -textvariable -activebackground -activeforeground -insertbackground \ -anchor -orient -troughcolor -nonewline -expand -type -message \ -title -offset -in -after -yscroll -xscroll -forward -regexp -count \ -exact -padx -ipadx -filetypes -all -from -to -label -value -variable \ -regexp -backwards -forwards -bd -pady -ipady -state -row -column \ -cursor -highlightcolors -linemap -menu -tearoff -displayof -cursor \ -underline -tags -tag] ctext::addHighlightClass .f.t stackControl red {proc uplevel namespace while for foreach if else} ctext::addHighlightClassWithOnlyCharStart .f.t vars mediumspringgreen "\$" ctext::addHighlightClass .f.t htmlText yellow " " ctext::addHighlightClass .f.t variable_funcs gold {set global variable unset} ctext::addHighlightClassForSpecialChars .f.t brackets green {[]{}} ctext::addHighlightClassForRegexp .f.t paths lightblue {\.[a-zA-Z0-9\_\-]+} ctext::addHighlightClassForRegexp .f.t comments khaki {#[^\n\r]*} #After overloading, insertion is a little slower with the #regular insert, so use fastinsert. #set fi [open Ctext_Bug_Crasher.tcl r] set fi [open long_test_script r] .f.t fastinsert end [read $fi] close $fi pack [frame .f1] -fill x pack [button .f1.append -text Append -command {.f.t append}] -side left pack [button .f1.cut -text Cut -command {.f.t cut}] -side left pack [button .f1.copy -text Copy -command {.f.t copy}] -side left pack [button .f1.paste -text Paste -command {.f.t paste}] -side left .f.t highlight 1.0 end pack [button .f1.test -text {Remove all Tags and Highlight} \ -command {puts [time { foreach tag [.f.t tag names] { .f.t tag remove $tag 1.0 end } update idletasks .f.t highlight 1.0 end }] } ] -side left pack [button .f1.fastdel -text {Fast Delete} -command {.f.t fastdelete 1.0 end}] -side left pack [frame .f2] -fill x pack [button .f2.test2 -text {Scrollbar Command {}} -command {.f.t config -yscrollcommand {}}] -side left pack [button .f2.cl -text {Clear Classes} -command {ctext::clearHighlightClasses .f.t}] -side left pack [button .f2.des -text Destroy -command {destroy .f.t}] -side left pack [button .f2.editModSet0 -text "Set Modified 0" -command {puts [.f.t edit modified 0]}] -side left pack [button .f2.editModGet -text "Print Modified" -command {puts [.f.t edit modified]}] -side left pack [button .f2.exit -text Exit -command exit] -side left puts [.f.t cget -linemap] puts [.f.t cget -linemapfg] puts [.f.t cget -linemapbg] puts [.f.t cget -bg] } main tcltk2/inst/tklibs/ctext3.2/long_test_script0000644000176000001440000004742612215417550020650 0ustar ripleyusers#By George Peter Staplin namespace eval cscrollbar { variable buttonPressed 0 variable lastX 0 variable lastY 0 variable up_xbm { #define up_width 18 #define up_height 12 static unsigned char up_bits[] = { 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x03, 0x00, 0x80, 0x07, 0x00, 0xc0, 0x0f, 0x00, 0xe0, 0x1f, 0x00, 0xf0, 0x3f, 0x00, 0xf8, 0x7f, 0x00, 0xfc, 0xff, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; } variable down_xbm { #define down_width 18 #define down_height 12 static char down_bits[] = { 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0xff, 0x00, 0xf8, 0x7f, 0x00, 0xf0, 0x3f, 0x00, 0xe0, 0x1f, 0x00, 0xc0, 0x0f, 0x00, 0x80, 0x07, 0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 }; } variable left_xbm { #define left_width 12 #define left_height 18 static char left_bits[] = { 0x00, 0x00, 0x00, 0x00, 0x00, 0x01, 0x80, 0x01, 0xc0, 0x01, 0xe0, 0x01, 0xf0, 0x01, 0xf8, 0x01, 0xfc, 0x01, 0xfc, 0x01, 0xf8, 0x01, 0xf0, 0x01, 0xe0, 0x01, 0xc0, 0x01, 0x80, 0x01, 0x00, 0x01, 0x00, 0x00, 0x00, 0x00 }; } variable right_xbm { #define right_width 12 #define right_height 18 static char right_bits[] = { 0x00, 0x00, 0x00, 0x00, 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01, 0xf8, 0x03, 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00, 0x08, 0x00, 0x00, 0x00, 0x00, 0x00 }; } } #This creates the scrollbar and an instance command for it. #cmdArgs represents the initial arguments. cmdArgs becomes smaller #gradually as options/flags are processed, and if it contains #anything else afterward an error is reported. proc cscrollbar {win args} { if {[expr {[llength $args] & 1}] != 0} { return -code error "Invalid number of arguments given to cscrollbar\ (uneven number): $args" } frame $win -class Cscrollbar upvar #0 _cscrollbar$win ar button .__temp set cmdArgs(-orient) vertical set cmdArgs(-bg) [option get $win background Color1] if {$cmdArgs(-bg) == ""} { set cmdArgs(-bg) [.__temp cget -bg] } set cmdArgs(-fg) [option get $win foreground Color1] if {$cmdArgs(-fg) == ""} { set cmdArgs(-fg) [.__temp cget -fg] } set cmdArgs(-slidercolor) [option get $win sliderColor Color1] if {$cmdArgs(-slidercolor) == ""} { set cmdArgs(-slidercolor) blue } set cmdArgs(-gradient1) [option get $win gradient1 Color1] if {$cmdArgs(-gradient1) == ""} { set cmdArgs(-gradient1) royalblue3 } set cmdArgs(-gradient2) [option get $win gradient2 Color1] if {$cmdArgs(-gradient2) == ""} { set cmdArgs(-gradient2) gray90 } set ar(sliderPressed) 0 destroy .__temp array set cmdArgs $args array set ar [array get cmdArgs] unset cmdArgs(-slidercolor) unset cmdArgs(-gradient1) unset cmdArgs(-gradient2) #synonym flags foreach long {background foreground} short {bg fg} { if {[info exists cmdArgs(-$long)] == 1} { set cmdArgs(-$short) $cmdArgs(-$long) unset cmdArgs(-long) } } if {$cmdArgs(-orient) == "vertical"} { cscrollbar::createVertical $win $cmdArgs(-bg) $cmdArgs(-fg) } elseif {$cmdArgs(-orient) == "horizontal"} { cscrollbar::createHorizontal $win $cmdArgs(-bg) $cmdArgs(-fg) } else { return -code error {Invalid -orient option -- use vertical or horizontal} } unset cmdArgs(-orient) unset cmdArgs(-fg) unset cmdArgs(-bg) if {[info exists cmdArgs(-command)] == 1} { bind $win.1 "set cscrollbar::buttonPressed 1; cscrollbar::moveUnit {$cmdArgs(-command)} -1 %W" bind $win.1 "set cscrollbar::buttonPressed 0; cscrollbar::moveUnit {$cmdArgs(-command)} -1 %W" bind $win.c "cscrollbar::sliderNotPressed $win" bind $win.2 "set cscrollbar::buttonPressed 1; cscrollbar::moveUnit {$cmdArgs(-command)} 1 %W" bind $win.2 "set cscrollbar::buttonPressed 0; cscrollbar::moveUnit {$cmdArgs(-command)} 1 %W" bind $win.3 "set cscrollbar::buttonPressed 1; cscrollbar::moveUnit {$cmdArgs(-command)} -1 %W" bind $win.3 "set cscrollbar::buttonPressed 0; cscrollbar::moveUnit {$cmdArgs(-command)} -1 %W" bind $win.4 "set cscrollbar::buttonPressed 1; cscrollbar::moveUnit {$cmdArgs(-command)} 1 %W" bind $win.4 "set cscrollbar::buttonPressed 0; cscrollbar::moveUnit {$cmdArgs(-command)} 1 %W" bind $win "after idle [list cscrollbar::updateView $win]" unset cmdArgs(-command) } if {[llength [array names cmdArgs]] != 0} { return -code error "Invalid argument sent to cscrollbar: [array get cmdArgs]" } rename $win _cscrollbarJunk$win bind $win "rename $win {};" proc $win {cmd args} "eval cscrollbar::instanceCmd $win \$cmd \$args" return $win } proc cscrollbar::updateView {win} { upvar #0 _cscrollbar$win ar if {[catch $ar(-command) res] && $res != ""} { $win set 0 1 } } proc cscrollbar::instanceCmd {self cmd args} { upvar #0 _cscrollbar$self ar switch -glob -- $cmd { cget { if {[info exists ar($args)] == 1} { return $ar($args) } else { return -code error "unknown argument(s) to cget: $args" } } conf* { if {[llength $args] == 0} { foreach name [array names ar -*] { append res "{$name $ar($name)} " } return $res } array set cmdArgs $args foreach long {background foreground} short {bg fg} { if {[info exists cmdArgs(-$long)] == 1} { set cmdArgs(-$short) $cmdArgs(-$long) unset cmdArgs(-$long) } } if {[info exists cmdArgs(-gradient1)] == 1} { set ar(-gradient1) $cmdArgs(-gradient1) event generate $self } if {[info exists cmdArgs(-gradient2)] == 2} { set ar(-gradient2) $cmdArgs(-gradient2) event generate $self } if {[info exists cmdArgs(-bg)] == 1} { set ar(-bg) $cmdArgs(-bg) $self.1 config -bg $ar(-bg) $self.c config -bg $ar(-bg) $self.2 config -bg $ar(-bg) if {$ar(-orient) == "vertical"} { $ar(upImage) config -background $ar(-bg) $ar(upDisabledImage) config -background $ar(-bg) $ar(downImage) config -background $ar(-bg) $ar(downDisabledImage) config -background $ar(-bg) } if {$ar(-orient) == "horizontal"} { $ar(leftImage) config -background $ar(-bg) $ar(leftDisabledImage) config -background $ar(-bg) $ar(rightImage) config -background $ar(-bg) $ar(rightDisabledImage) config -background $ar(-bg) } unset cmdArgs(-bg) } if {[info exists cmdArgs(-fg)] == 1} { set ar(-fg) $cmdArgs(-fg) $self.1 config -fg $ar(-fg) $self.2 config -fg $ar(-fg) $self.3 config -fg $ar(-fg) $self.4 config -fg $ar(-fg) if {$ar(-orient) == "vertical"} { $ar(upImage) config -foreground $ar(-fg) $ar(downImage) config -foreground $ar(-fg) } if {$ar(-orient) == "horizontal"} { $ar(leftImage) config -foreground $ar(-fg) $ar(rightImage) config -foreground $ar(-fg) } unset cmdArgs(-fg) } if {[info exists cmdArgs(-slidercolor)] == 1} { set ar(-slidercolor) $cmdArgs(-slidercolor) $self.c itemconfigure slider -fill $ar(-slidercolor) unset cmdArgs(-slidercolor) } if {[info exists cmdArgs(-command)] == 1} { set ar(-command) $cmdArgs(-command) bind $self.1 "set cscrollbar::buttonPressed 1; cscrollbar::moveUnit {$ar(-command)} -1 %W" bind $self.1 "set cscrollbar::buttonPressed 0; cscrollbar::moveUnit {$ar(-command)} -1 %W" bind $self.c "cscrollbar::sliderNotPressed $self" bind $self.2 "set cscrollbar::buttonPressed 1; cscrollbar::moveUnit {$ar(-command)} 1 %W" bind $self.2 "set cscrollbar::buttonPressed 0; cscrollbar::moveUnit {$ar(-command)} 1 %W" bind $self.3 "set cscrollbar::buttonPressed 1; cscrollbar::moveUnit {$ar(-command)} -1 %W" bind $self.3 "set cscrollbar::buttonPressed 0; cscrollbar::moveUnit {$ar(-command)} -1 %W" bind $self.4 "set cscrollbar::buttonPressed 1; cscrollbar::moveUnit {$ar(-command)} 1 %W" bind $self.4 "set cscrollbar::buttonPressed 0; cscrollbar::moveUnit {$ar(-command)} 1 %W" bind $self " if {\[catch {$ar(-command)} res\] == 0 && \$res != \"\"} { $self set \$res } " unset cmdArgs(-command) } set res [llength [array names cmdArgs]] if {$res != 0} { return -code error "The following options were not recognized\ by cscrollbar: [array get cmdArgs]" } } set { set start [lindex $args 0] set end [lindex $args 1] #somehow this becomes a list when I don't want it to be. if {$end == ""} { set end [lindex $start 1] set start [lindex $start 0] } if {$end <= 0} { set end 1 } update idletasks if {$ar(-orient) == "vertical"} { if {$start == 0} { $self.1 config -image $ar(upDisabledImage) $self.3 config -image $ar(upDisabledImage) } else { $self.1 config -image $ar(upImage) $self.3 config -image $ar(upImage) } if {$end == 1} { $self.2 config -image $ar(downDisabledImage) $self.4 config -image $ar(downDisabledImage) } else { $self.2 config -image $ar(downImage) $self.4 config -image $ar(downImage) } if {$ar(sliderPressed) == 1} { return } #-2 is done for the border set areaHeight [expr {([winfo height $self.c] - 2)}] set startPos [expr {$start * $areaHeight}] set endPos [expr {$end * $areaHeight}] if {$endPos <= 0} { set endPos $areaHeight } $self.c coords slider 0 $startPos [winfo width $self.c] $endPos } if {$ar(-orient) == "horizontal"} { if {$start == 0} { $self.1 config -image $ar(leftDisabledImage) $self.3 config -image $ar(leftDisabledImage) } else { $self.1 config -image $ar(leftImage) $self.3 config -image $ar(leftImage) } if {$end == 1} { $self.2 config -image $ar(rightDisabledImage) $self.4 config -image $ar(rightDisabledImage) } else { $self.2 config -image $ar(rightImage) $self.4 config -image $ar(rightImage) } if {$ar(sliderPressed) == 1} { return } set areaWidth [expr {([winfo width $self.c] - 2)}] set startPos [expr {$start * $areaWidth}] set endPos [expr {$end * $areaWidth}] if {$endPos <= 0} { set endPos $areaWidth } $self.c coords slider $startPos 0 $endPos [winfo height $self.c] } } default { #puts "$cmd $args" } } } proc cscrollbar::createHorizontal {win bg fg} { upvar #0 _cscrollbar$win ar set bd 1 set ar(leftImage) [image create bitmap -data $cscrollbar::left_xbm \ -foreground $fg -background $bg] set ar(leftDisabledImage) [image create bitmap -data $cscrollbar::left_xbm \ -foreground gray50 -background $bg] set ar(rightImage) [image create bitmap -data $cscrollbar::right_xbm \ -foreground $fg -background $bg] set ar(rightDisabledImage) [image create bitmap -data $cscrollbar::right_xbm \ -foreground gray50 -background $bg] grid [label $win.1 -image $ar(leftDisabledImage) -relief raised -bg $bg -fg $fg -bd $bd] \ -row 0 -column 0 -sticky w grid [label $win.2 -image $ar(rightDisabledImage) -relief raised -bg $bg -fg $fg -bd $bd] \ -row 0 -column 1 -sticky w grid [canvas $win.c -relief flat -highlightthickness 0 \ -height [winfo reqheight $win.1] -width 10 -bg $bg] \ -row 0 -column 2 -sticky ew grid columnconfigure $win 2 -weight 1 grid [label $win.3 -image $ar(leftDisabledImage) -relief raised -bg $bg -fg $fg -bd $bd] \ -row 0 -column 3 -sticky e grid [label $win.4 -image $ar(rightDisabledImage) -relief raised -bg $bg -fg $fg -bd $bd] \ -row 0 -column 4 -sticky e cscrollbar::drawSlider $win 0 0 1 1 horizontal $win.c bind slider "cscrollbar::moveSlider $win horizontal %x" $win.c bind slider " set cscrollbar::lastX \[$win.c canvasx %x\] set cscrollbar::lastY \[$win.c canvasy %y\] " bind $win.c "cscrollbar::drawBackground $win horizontal" } proc cscrollbar::createVertical {win bg fg} { upvar #0 _cscrollbar$win ar set bd 1 set ar(upImage) [image create bitmap -data $cscrollbar::up_xbm \ -foreground $fg -background $bg] set ar(upDisabledImage) [image create bitmap -data $cscrollbar::up_xbm \ -foreground gray50 -background $bg] set ar(downImage) [image create bitmap -data $cscrollbar::down_xbm \ -foreground $fg -background $bg] set ar(downDisabledImage) [image create bitmap -data $cscrollbar::down_xbm \ -foreground gray50 -background $bg] grid [label $win.1 -image $ar(upDisabledImage) -relief raised -bg $bg -fg $fg -bd $bd] \ -row 0 -column 0 -sticky n grid [label $win.2 -image $ar(downDisabledImage) -relief raised -bg $bg -fg $fg -bd $bd] \ -row 1 -column 0 -sticky n grid [canvas $win.c -relief flat -highlightthickness 0 \ -width [winfo reqwidth $win.1] -height 10 -bg $bg] \ -row 2 -column 0 -sticky ns grid rowconfigure $win 2 -weight 1 grid [label $win.3 -image $ar(upDisabledImage) -relief raised -bg $bg -fg $fg -bd $bd] \ -row 3 -column 0 -sticky s grid [label $win.4 -image $ar(downDisabledImage) -relief raised -bg $bg -fg $fg -bd $bd] \ -row 4 -column 0 -sticky s cscrollbar::drawSlider $win 0 0 1 1 vertical $win.c bind slider "cscrollbar::moveSlider $win vertical %y" $win.c bind slider " set cscrollbar::lastX \[$win.c canvasx %x\] set cscrollbar::lastY \[$win.c canvasy %y\] " bind $win.c "cscrollbar::drawBackground $win vertical" } #Based on Richard Suchenwirth's gradient code from one of his train #projects. proc cscrollbar::drawBackground {win type} { upvar #0 _cscrollbar$win ar set canv $win.c set x1 0 set y1 0 set x2 [expr {[winfo width $canv] + 8}] set y2 [expr {[winfo height $canv] + 8}] set c1 $ar(-gradient1) set c2 $ar(-gradient2) $canv delete background foreach {r1 g1 b1} [winfo rgb $canv $c1] break foreach {r2 g2 b2} [winfo rgb $canv $c2] break set redDiff [expr {$r2 - $r1}] set greenDiff [expr {$g2 - $g1}] set blueDiff [expr {$b2 - $b1}] switch $type { horizontal { set yDiff [expr {$y2 - $y1}] set steps [expr {int(abs($yDiff))}] if {$steps > 255} { set steps 255 } for {set i 2} {$i < $steps} {incr i} { set p [expr {double($i) / $steps}] set y [expr {$y1 + $yDiff * $p}] set r [expr {int($r1 + $redDiff * $p)}] set g [expr {int($g1 + $greenDiff * $p)}] set b [expr {int($b1 + $blueDiff * $p)}] set fillColor "#" foreach color {r g b} { set preColor [format "%2.2x" [set $color]] set color [format "%2.2s" $preColor] append fillColor $color } $canv create rectangle $x1 $y $x2 $y2 -outline {} -tag background \ -fill $fillColor } } vertical { set xDiff [expr {$x2 - $x1}] set steps [expr {int(abs($xDiff))}] if {$steps > 255} { set steps 255 } for {set i 2} {$i < $steps} {incr i} { set p [expr {double($i) / $steps}] set x [expr {$x1 + $xDiff * $p}] set r [expr {int($r1 + $redDiff * $p)}] set g [expr {int($g1 + $greenDiff * $p)}] set b [expr {int($b1 + $blueDiff * $p)}] set fillColor "#" foreach color {r g b} { set preColor [format "%2.2x" [set $color]] set color [format "%2.2s" $preColor] append fillColor $color } $canv create rectangle $x $y1 $x2 $y2 -outline {} -tag background \ -fill $fillColor } } default { return -code error "unknown direction \"$type\": must be one of horizontal or vertical" } } $win.c bind background "cscrollbar::scrollPages $win $type %x %y" $win.c lower background } proc cscrollbar::drawSlider {win x1 y1 x2 y2 type} { upvar #0 _cscrollbar$win ar #update idletasks $win.c delete slider if {$type == "vertical"} { set canvasWidth [winfo width $win.c] $win.c create rectangle 0 $y1 $canvasWidth $y2 \ -fill $ar(-slidercolor) -outline "" -tag slider -stipple gray50 return } if {$type == "horizontal"} { set canvasHeight [winfo height $win.c] $win.c create rectangle $x1 0 $x2 $canvasHeight \ -fill $ar(-slidercolor) -outline "" -tag slider -stipple gray50 return } } proc cscrollbar::moveSlider {win type position} { variable lastX variable lastY upvar #0 _cscrollbar$win ar if {$type == "vertical"} { #move the slider y values which are 1 and 3 in the coords list set sliderStartY [lindex [$win.c coords slider] 1] set sliderEndY [lindex [$win.c coords slider] 3] set sliderHeight [expr {$sliderEndY - $sliderStartY}] set areaHeight [expr {[winfo height $win.c] - 1}] set newY [expr {$position - $lastY}] set upBoundResult [expr {($sliderStartY + $newY) < 0}] set downBoundResult [expr {($sliderEndY + $newY) > $areaHeight}] if {$upBoundResult != 1 && $downBoundResult != 1} { $win.c move slider 0 $newY set lastY $position } elseif {$upBoundResult == 1} { set lastY [expr {$lastY - $sliderStartY}] $win.c move slider 0 [expr {-$sliderStartY}] } elseif {$downBoundResult == 1} { set amountToMove [expr {-$sliderStartY + ($areaHeight - $sliderHeight)}] set lastY [expr {$lastY + $amountToMove}] $win.c move slider 0 $amountToMove } if {[info exists ar(-command)] == 1} { set ar(sliderPressed) 1 eval $ar(-command) moveto [expr {$sliderStartY / $areaHeight}] } return } if {$type == "horizontal"} { #move the slider x values which are 0 and 2 in the coords list set sliderStartX [lindex [$win.c coords slider] 0] set sliderEndX [lindex [$win.c coords slider] 2] set sliderWidth [expr {$sliderEndX - $sliderStartX}] set areaWidth [expr {[winfo width $win.c] - 1}] set newX [expr {$position - $lastX}] set leftBoundResult [expr {($sliderStartX + $newX) < 0}] set rightBoundResult [expr {($sliderEndX + $newX) > $areaWidth}] if {$leftBoundResult != 1 && $rightBoundResult != 1} { $win.c move slider $newX 0 set lastX $position } elseif {$leftBoundResult == 1} { set lastX [expr {$lastX - $sliderStartX}] $win.c move slider [expr {-$sliderStartX}] 0 } elseif {$rightBoundResult == 1} { set amountToMove [expr {-$sliderStartX + ($areaWidth - $sliderWidth)}] set lastX [expr {$lastX + $amountToMove}] $win.c move slider $amountToMove 0 } if {[info exists ar(-command)] == 1} { set ar(sliderPressed) 1 eval $ar(-command) moveto [expr {$sliderStartX / $areaWidth}] } return } } #This moves the widget being scrolled a unit at a time. #It is invoked by the arrow buttons. The arrow buttons #are actually labels with bitmaps that have the -relief #change. proc cscrollbar::moveUnit {cmd unit self} { variable buttonPressed eval $cmd scroll $unit units $self config -relief sunken if {$buttonPressed == 1} { after 40 "cscrollbar::moveUnit {$cmd} $unit $self" } else { $self config -relief raised } } #This means that someone has pressed the trough/background #of the scrollbar, so we should scroll a page at a time. #Unlike Tk's scrollbar I don't continue scrolling while #the mouse is held down. Instead I chose to scroll once. #If the user wants it to continue they can press the mouse #again. proc cscrollbar::scrollPages {win type x y} { upvar #0 _cscrollbar$win ar if {$type == "horizontal"} { set sliderStartX [lindex [$win.c coords slider] 0] set sliderEndX [lindex [$win.c coords slider] 2] if {$x < $sliderStartX} { eval [concat $ar(-command) scroll -1 pages] } if {$x > $sliderEndX} { eval [concat $ar(-command) scroll 1 pages] } } if {$type == "vertical"} { set sliderStartY [lindex [$win.c coords slider] 1] set sliderEndY [lindex [$win.c coords slider] 3] if {$y < $sliderStartY} { eval [concat $ar(-command) scroll -1 pages] } if {$y > $sliderEndY} { eval [concat $ar(-command) scroll 1 pages] } } } proc cscrollbar::sliderNotPressed {win} { upvar #0 _cscrollbar$win ar set ar(sliderPressed) 0 if {[catch {$ar(-command)} res] == 0 && $res != ""} { $win set $res } } tcltk2/inst/tklibs/ctext3.2/README0000644000176000001440000001146312215417550016213 0ustar ripleyusers# RCS: @(#) $Id: README,v 1.3 2005/04/07 02:33:30 andreas_kupries Exp $ o Author George Peter Staplin See also: Thanks (below) o Licensing BSD style see the LICENSE file o Installation Ctext requires only one file named ctext.tcl. You can source this file or if you prefer to use "package require ctext" you can use the install.tcl script. The install script can be run like so: wish8.4 install.tcl If you are a developer I highly recommend that you study the Usage section below. If you need an example then see the test files (especialy ctext_test_interactive.tcl). o How it Works Ctext overloads the text widget and provides new commands, named highlight, copy, paste, cut, append, and edit. It also provides several commands that allow you to define classes. Each class corresponds to a tag in the widget. o Usage Ctext can be used like so: pack [ctext .t] .t fastinsert end $data .t highlight 1.0 end The copy, paste, and cut widget commands are frontends for tk_text*, but they don't require giving an argument for the text widget window. I have also addded an append command, which appends the current selection to the existing clipboard text. An edit modified command is available that keeps track of whether or not data in the widget has been modified. .t edit modified would return 0 if the data hasn't been modified. To set the value after inserting text you can use .t edit modified 0. It will automatically be set to 1 during insertion/deletion cut/paste etc. During insertion and deletion of text in the widget the tags and highlighting will be automatically updated, unless you specify -highlight 0 during creation or instance configuration of the widget. All of the flags that the text widget supports work. It also supports new flags. These new flags are: -linemap creates a line number list on the left of the widget. -linemapfg changes the foreground of the linemap. The default is the same color as the main text widget. -linemapbg changes the background of the linemap. The default is the same color as the main text widget. -linemap_select_fg changes the selected line foreground. The default is black. -linemap_select_bg changes the selected line background. The default is yellow. -linemap_mark_command calls a procedure or command with the path of the ctext window, the type which is either marked or unmarked, and finally the line number selected. The proc prototype is: proc linemark_cmd {win type line}. See also ctext_test_interactive.tcl -highlight takes a boolean value which defines whether or not to highlight text which is inserted or deleted. The default is 1. -linemap_markable takes a boolean value which specifies whether or not lines in the linemap are markable with the mouse. The default is 1. Four highlighting procedures are available for adding keywords. Each proc takes a class, color, keyword, and window argument. The highlight widget command will automatically use each class that you add with any of the three functions. If you want to change the font of a class or another attribute you can run a command like this: .t tag configure $className -font {Helvetica 16} Note that the tag is created when you add a class. Normal keywords: ctext::addHighlightClass .t class color [list string1 string2 ...] Strings that start with chars like $, for $var: ctext::addHighlightClassWithOnlyCharStart .t class color "\$" A series of characters in a string ctext:addHighlightClassForSpecialChars .t class color {[]{}} Comments, and other things that need regexp: ctext::addHighlightClassForRegexp .t class color {#\[^\n\]*} ctext::clearHighlightClasses clears all of the highlight classes from the widget specified. Example: ctext::clearHighlightClasses .t To get a list of classes defined for a widget do something like: ctext::getHighlightClasses .t To delete a highlight class do something like: ctext::deleteHighlightClass .t classNameToDelete You can update a cursor while ctext highlights a large file by overriding ctext::update. Simply source ctext.tcl then create your ctext::update proc, and it will be called by ctext. This allows you to have a progress dialog, or animated cursor. If you are using C and want C comments highlighted you can use ctext::enableComments. You can modify the colors of C comments by configuring the tag _cComment after enabling with the afformentioned command. The C comment highlighting is disabled by default. I have personally tested it with Tcl/Tk 8.4.4 in NetBSD. It should work with all Tcl platforms. Please send comments and bugs to the tklib project at tcllib.sf.net o Thanks Kevin Kenny, Neil Madden, Jeffrey Hobbs, Richard Suchenwirth, Johan Bengtsson, Mac Cody, Gnther, Andreas Sievers, and Michael Schlenker tcltk2/inst/tklibs/ctext3.2/example_ws.tcl0000644000176000001440000000032212215417550020173 0ustar ripleyusers source ./ctext.tcl pack [ctext {.t blah}] ctext::addHighlightClass {.t blah} c blue [list bat ball boot cat hat] ctext::addHighlightClass {.t blah} c2 red [list bozo bull bongo] {.t blah} highlight 1.0 end tcltk2/inst/tklibs/ctext3.2/example_scroll.tcl0000644000176000001440000000041412215417550021042 0ustar ripleyusers source ./ctext.tcl scrollbar .y -orient vertical -command {.t yview} ctext .t -xscrollcommand {.x set} -yscrollcommand {.y set} -wrap none scrollbar .x -orient horizontal -command {.t xview} grid .y -sticky ns grid .t -row 0 -column 1 grid .x -column 1 -sticky we tcltk2/inst/tklibs/ctext3.2/example_c.tcl0000755000176000001440000000433212215417550017774 0ustar ripleyusers#!/bin/sh # the next line restarts using wish \ exec wish "$0" ${1+"$@"} #use :: so I don't forget it's global #set ::tcl_traceExec 1 proc highlight:addClasses {win} { ctext::addHighlightClassForSpecialChars $win brackets green {[]} ctext::addHighlightClassForSpecialChars $win braces lawngreen {{}} ctext::addHighlightClassForSpecialChars $win parentheses palegreen {()} ctext::addHighlightClassForSpecialChars $win quotes "#c65e3c" {"'} ctext::addHighlightClass $win control red [list namespace while for if else do switch case] ctext::addHighlightClass $win types purple [list \ int char u_char u_int long double float typedef unsigned signed] ctext::addHighlightClass $win macros mediumslateblue [list \ #define #undef #if #ifdef #ifndef #endif #elseif #include #import #exclude] ctext::addHighlightClassForSpecialChars $win math cyan {+=*-/&^%!|<>} } proc main {} { source ./ctext.tcl pack [frame .f] -fill both -expand 1 #Of course this could be cscrollbar instead, but it's not as common. pack [scrollbar .f.s -command ".f.t yview"] -side right -fill y #Dark colors pack [ctext .f.t -linemap 1 \ -bg black -fg white -insertbackground yellow \ -yscrollcommand ".f.s set"] -fill both -expand 1 highlight:addClasses .f.t ctext::enableComments .f.t set fi [open test.c r] .f.t fastinsert end [read $fi] close $fi pack [button .append -text Append -command {.f.t append}] -side left pack [button .cut -text Cut -command {.f.t cut}] -side left pack [button .copy -text Copy -command {.f.t copy}] -side left pack [button .paste -text Paste -command {.f.t paste}] -side left .f.t highlight 1.0 end pack [button .test -text {Remove all Tags and Highlight} \ -command {puts [time { foreach tag [.f.t tag names] { .f.t tag remove $tag 1.0 end } update idletasks .f.t highlight 1.0 end }] } ] -side left pack [button .test2 -text {Scrollbar Command {}} -command {.f.t config -yscrollcommand {}}] -side left pack [button .cl -text {Clear Classes} \ -command {ctext::clearHighlightClasses .f.t}] -side left pack [button .exit -text Exit -command exit] -side left #pack [ctext .ct2 -linemap 1] -side bottom #update #console show #puts [.f.t cget -linemap] #puts [.f.t cget -bg] } main tcltk2/inst/tklibs/ctext3.2/ctext.tcl0000644000176000001440000006115312215417550017167 0ustar ripleyusers# By George Peter Staplin # See also the README for a list of contributors # RCS: @(#) $Id: ctext.tcl,v 1.7 2008/08/19 21:08:27 georgeps Exp $ package require Tk package provide ctext 3.2 namespace eval ctext {} #win is used as a unique token to create arrays for each ctext instance proc ctext::getAr {win suffix name} { set arName __ctext[set win][set suffix] uplevel [list upvar #0 $arName $name] return $arName } proc ctext {win args} { if {[llength $args] & 1} { return -code error "invalid number of arguments given to ctext (uneven number after window) : $args" } frame $win -class Ctext set tmp [text .__ctextTemp] ctext::getAr $win config ar set ar(-fg) [$tmp cget -foreground] set ar(-bg) [$tmp cget -background] set ar(-font) [$tmp cget -font] set ar(-relief) [$tmp cget -relief] destroy $tmp set ar(-yscrollcommand) "" set ar(-linemap) 1 set ar(-linemapfg) $ar(-fg) set ar(-linemapbg) $ar(-bg) set ar(-linemap_mark_command) {} set ar(-linemap_markable) 1 set ar(-linemap_select_fg) black set ar(-linemap_select_bg) yellow set ar(-highlight) 1 set ar(win) $win set ar(modified) 0 set ar(commentsAfterId) "" set ar(highlightAfterId) "" set ar(blinkAfterId) "" set ar(ctextFlags) [list -yscrollcommand -linemap -linemapfg -linemapbg \ -font -linemap_mark_command -highlight -linemap_markable -linemap_select_fg \ -linemap_select_bg] array set ar $args foreach flag {foreground background} short {fg bg} { if {[info exists ar(-$flag)] == 1} { set ar(-$short) $ar(-$flag) unset ar(-$flag) } } #Now remove flags that will confuse text and those that need modification: foreach arg $ar(ctextFlags) { if {[set loc [lsearch $args $arg]] >= 0} { set args [lreplace $args $loc [expr {$loc + 1}]] } } text $win.l -font $ar(-font) -width 1 -height 1 \ -relief $ar(-relief) -fg $ar(-linemapfg) \ -bg $ar(-linemapbg) -takefocus 0 set topWin [winfo toplevel $win] bindtags $win.l [list $win.l $topWin all] if {$ar(-linemap) == 1} { grid $win.l -sticky ns -row 0 -column 0 } set args [concat $args [list -yscrollcommand [list ctext::event:yscroll $win $ar(-yscrollcommand)]]] #escape $win, because it could have a space eval text \$win.t -font \$ar(-font) $args grid $win.t -row 0 -column 1 -sticky news grid rowconfigure $win 0 -weight 100 grid columnconfigure $win 1 -weight 100 bind $win.t [list ctext::linemapUpdate $win] bind $win.l [list ctext::linemapToggleMark $win %y] bind $win.t [list ctext::linemapUpdate $win] rename $win __ctextJunk$win rename $win.t $win._t bind $win [list ctext::event:Destroy $win %W] bindtags $win.t [linsert [bindtags $win.t] 0 $win] interp alias {} $win {} ctext::instanceCmd $win interp alias {} $win.t {} $win #If the user wants C comments they should call ctext::enableComments ctext::disableComments $win ctext::modified $win 0 ctext::buildArgParseTable $win return $win } proc ctext::event:yscroll {win clientData args} { ctext::linemapUpdate $win if {$clientData == ""} { return } uplevel #0 $clientData $args } proc ctext::event:Destroy {win dWin} { if {![string equal $win $dWin]} { return } ctext::getAr $win config configAr catch {after cancel $configAr(commentsAfterId)} catch {after cancel $configAr(highlightAfterId)} catch {after cancel $configAr(blinkAfterId)} catch {rename $win {}} interp alias {} $win.t {} ctext::clearHighlightClasses $win array unset [ctext::getAr $win config ar] } #This stores the arg table within the config array for each instance. #It's used by the configure instance command. proc ctext::buildArgParseTable win { set argTable [list] lappend argTable any -linemap_mark_command { set configAr(-linemap_mark_command) $value break } lappend argTable {1 true yes} -linemap { grid $self.l -sticky ns -row 0 -column 0 grid columnconfigure $self 0 \ -minsize [winfo reqwidth $self.l] set configAr(-linemap) 1 break } lappend argTable {0 false no} -linemap { grid forget $self.l grid columnconfigure $self 0 -minsize 0 set configAr(-linemap) 0 break } lappend argTable any -yscrollcommand { set cmd [list $self._t config -yscrollcommand [list ctext::event:yscroll $self $value]] if {[catch $cmd res]} { return $res } set configAr(-yscrollcommand) $value break } lappend argTable any -linemapfg { if {[catch {winfo rgb $self $value} res]} { return -code error $res } $self.l config -fg $value set configAr(-linemapfg) $value break } lappend argTable any -linemapbg { if {[catch {winfo rgb $self $value} res]} { return -code error $res } $self.l config -bg $value set configAr(-linemapbg) $value break } lappend argTable any -font { if {[catch {$self.l config -font $value} res]} { return -code error $res } $self._t config -font $value set configAr(-font) $value break } lappend argTable {0 false no} -highlight { set configAr(-highlight) 0 break } lappend argTable {1 true yes} -highlight { set configAr(-highlight) 1 break } lappend argTable {0 false no} -linemap_markable { set configAr(-linemap_markable) 0 break } lappend argTable {1 true yes} -linemap_markable { set configAr(-linemap_markable) 1 break } lappend argTable any -linemap_select_fg { if {[catch {winfo rgb $self $value} res]} { return -code error $res } set configAr(-linemap_select_fg) $value $self.l tag configure lmark -foreground $value break } lappend argTable any -linemap_select_bg { if {[catch {winfo rgb $self $value} res]} { return -code error $res } set configAr(-linemap_select_bg) $value $self.l tag configure lmark -background $value break } ctext::getAr $win config ar set ar(argTable) $argTable } proc ctext::commentsAfterIdle {win} { ctext::getAr $win config configAr if {"" eq $configAr(commentsAfterId)} { set configAr(commentsAfterId) [after idle [list ctext::comments $win [set afterTriggered 1]]] } } proc ctext::highlightAfterIdle {win lineStart lineEnd} { ctext::getAr $win config configAr if {"" eq $configAr(highlightAfterId)} { set configAr(highlightAfterId) [after idle [list ctext::highlight $win $lineStart $lineEnd [set afterTriggered 1]]] } } proc ctext::instanceCmd {self cmd args} { #slightly different than the RE used in ctext::comments set commentRE {\"|\\|'|/|\*} switch -glob -- $cmd { append { if {[catch {$self._t get sel.first sel.last} data] == 0} { clipboard append -displayof $self $data } } cget { set arg [lindex $args 0] ctext::getAr $self config configAr foreach flag $configAr(ctextFlags) { if {[string match ${arg}* $flag]} { return [set configAr($flag)] } } return [$self._t cget $arg] } conf* { ctext::getAr $self config configAr if {0 == [llength $args]} { set res [$self._t configure] set del [lsearch -glob $res -yscrollcommand*] set res [lreplace $res $del $del] foreach flag $configAr(ctextFlags) { lappend res [list $flag [set configAr($flag)]] } return $res } array set flags {} foreach flag $configAr(ctextFlags) { set loc [lsearch $args $flag] if {$loc < 0} { continue } if {[llength $args] <= ($loc + 1)} { #.t config -flag return [set configAr($flag)] } set flagArg [lindex $args [expr {$loc + 1}]] set args [lreplace $args $loc [expr {$loc + 1}]] set flags($flag) $flagArg } foreach {valueList flag cmd} $configAr(argTable) { if {[info exists flags($flag)]} { foreach valueToCheckFor $valueList { set value [set flags($flag)] if {[string equal "any" $valueToCheckFor]} $cmd \ elseif {[string equal $valueToCheckFor [set flags($flag)]]} $cmd } } } if {[llength $args]} { #we take care of configure without args at the top of this branch uplevel 1 [linsert $args 0 $self._t configure] } } copy { tk_textCopy $self } cut { if {[catch {$self.t get sel.first sel.last} data] == 0} { clipboard clear -displayof $self.t clipboard append -displayof $self.t $data $self delete [$self.t index sel.first] [$self.t index sel.last] ctext::modified $self 1 } } delete { #delete n.n ?n.n set argsLength [llength $args] #first deal with delete n.n if {$argsLength == 1} { set deletePos [lindex $args 0] set prevChar [$self._t get $deletePos] $self._t delete $deletePos set char [$self._t get $deletePos] set prevSpace [ctext::findPreviousSpace $self._t $deletePos] set nextSpace [ctext::findNextSpace $self._t $deletePos] set lineStart [$self._t index "$deletePos linestart"] set lineEnd [$self._t index "$deletePos + 1 chars lineend"] #This pattern was used in 3.1. We may want to investigate using it again #eventually to reduce flicker. It caused a bug with some patterns. #if {[string equal $prevChar "#"] || [string equal $char "#"]} { # set removeStart $lineStart # set removeEnd $lineEnd #} else { # set removeStart $prevSpace # set removeEnd $nextSpace #} set removeStart $lineStart set removeEnd $lineEnd foreach tag [$self._t tag names] { if {[string equal $tag "_cComment"] != 1} { $self._t tag remove $tag $removeStart $removeEnd } } set checkStr "$prevChar[set char]" if {[regexp $commentRE $checkStr]} { ctext::commentsAfterIdle $self } ctext::highlightAfterIdle $self $lineStart $lineEnd ctext::linemapUpdate $self } elseif {$argsLength == 2} { #now deal with delete n.n ?n.n? set deleteStartPos [lindex $args 0] set deleteEndPos [lindex $args 1] set data [$self._t get $deleteStartPos $deleteEndPos] set lineStart [$self._t index "$deleteStartPos linestart"] set lineEnd [$self._t index "$deleteEndPos + 1 chars lineend"] eval \$self._t delete $args foreach tag [$self._t tag names] { if {[string equal $tag "_cComment"] != 1} { $self._t tag remove $tag $lineStart $lineEnd } } if {[regexp $commentRE $data]} { ctext::commentsAfterIdle $self } ctext::highlightAfterIdle $self $lineStart $lineEnd if {[string first "\n" $data] >= 0} { ctext::linemapUpdate $self } } else { return -code error "invalid argument(s) sent to $self delete: $args" } ctext::modified $self 1 } fastdelete { eval \$self._t delete $args ctext::modified $self 1 ctext::linemapUpdate $self } fastinsert { eval \$self._t insert $args ctext::modified $self 1 ctext::linemapUpdate $self } highlight { ctext::highlight $self [lindex $args 0] [lindex $args 1] ctext::comments $self } insert { if {[llength $args] < 2} { return -code error "please use at least 2 arguments to $self insert" } set insertPos [lindex $args 0] set prevChar [$self._t get "$insertPos - 1 chars"] set nextChar [$self._t get $insertPos] set lineStart [$self._t index "$insertPos linestart"] set prevSpace [ctext::findPreviousSpace $self._t ${insertPos}-1c] set data [lindex $args 1] eval \$self._t insert $args set nextSpace [ctext::findNextSpace $self._t insert] set lineEnd [$self._t index "insert lineend"] if {[$self._t compare $prevSpace < $lineStart]} { set prevSpace $lineStart } if {[$self._t compare $nextSpace > $lineEnd]} { set nextSpace $lineEnd } foreach tag [$self._t tag names] { if {[string equal $tag "_cComment"] != 1} { $self._t tag remove $tag $prevSpace $nextSpace } } set REData $prevChar append REData $data append REData $nextChar if {[regexp $commentRE $REData]} { ctext::commentsAfterIdle $self } ctext::highlightAfterIdle $self $lineStart $lineEnd switch -- $data { "\}" { ctext::matchPair $self "\\\{" "\\\}" "\\" } "\]" { ctext::matchPair $self "\\\[" "\\\]" "\\" } "\)" { ctext::matchPair $self "\\(" "\\)" "" } "\"" { ctext::matchQuote $self } } ctext::modified $self 1 ctext::linemapUpdate $self } paste { tk_textPaste $self ctext::modified $self 1 } edit { set subCmd [lindex $args 0] set argsLength [llength $args] ctext::getAr $self config ar if {"modified" == $subCmd} { if {$argsLength == 1} { return $ar(modified) } elseif {$argsLength == 2} { set value [lindex $args 1] set ar(modified) $value } else { return -code error "invalid arg(s) to $self edit modified: $args" } } else { #Tk 8.4 has other edit subcommands that I don't want to emulate. return [uplevel 1 [linsert $args 0 $self._t $cmd]] } } default { return [uplevel 1 [linsert $args 0 $self._t $cmd]] } } } proc ctext::tag:blink {win count {afterTriggered 0}} { if {$count & 1} { $win tag configure __ctext_blink -foreground [$win cget -bg] -background [$win cget -fg] } else { $win tag configure __ctext_blink -foreground [$win cget -fg] -background [$win cget -bg] } ctext::getAr $win config configAr if {$afterTriggered} { set configAr(blinkAfterId) "" } if {$count == 4} { $win tag delete __ctext_blink 1.0 end return } incr count if {"" eq $configAr(blinkAfterId)} { set configAr(blinkAfterId) [after 50 [list ctext::tag:blink $win $count [set afterTriggered 1]]] } } proc ctext::matchPair {win str1 str2 escape} { set prevChar [$win get "insert - 2 chars"] if {[string equal $prevChar $escape]} { #The char that we thought might be the end is actually escaped. return } set searchRE "[set str1]|[set str2]" set count 1 set pos [$win index "insert - 1 chars"] set endPair $pos set lastFound "" while 1 { set found [$win search -backwards -regexp $searchRE $pos] if {$found == "" || [$win compare $found > $pos]} { return } if {$lastFound != "" && [$win compare $found == $lastFound]} { #The search wrapped and found the previous search return } set lastFound $found set char [$win get $found] set prevChar [$win get "$found - 1 chars"] set pos $found if {[string equal $prevChar $escape]} { continue } elseif {[string equal $char [subst $str2]]} { incr count } elseif {[string equal $char [subst $str1]]} { incr count -1 if {$count == 0} { set startPair $found break } } else { #This shouldn't happen. I may in the future make it return -code error puts stderr "ctext seems to have encountered a bug in ctext::matchPair" return } } $win tag add __ctext_blink $startPair $win tag add __ctext_blink $endPair ctext::tag:blink $win 0 } proc ctext::matchQuote {win} { set endQuote [$win index insert] set start [$win index "insert - 1 chars"] if {[$win get "$start - 1 chars"] == "\\"} { #the quote really isn't the end return } set lastFound "" while 1 { set startQuote [$win search -backwards \" $start] if {$startQuote == "" || [$win compare $startQuote > $start]} { #The search found nothing or it wrapped. return } if {$lastFound != "" && [$win compare $lastFound == $startQuote]} { #We found the character we found before, so it wrapped. return } set lastFound $startQuote set start [$win index "$startQuote - 1 chars"] set prevChar [$win get $start] if {$prevChar == "\\"} { continue } break } if {[$win compare $endQuote == $startQuote]} { #probably just \" return } $win tag add __ctext_blink $startQuote $endQuote ctext::tag:blink $win 0 } proc ctext::enableComments {win} { $win tag configure _cComment -foreground khaki } proc ctext::disableComments {win} { catch {$win tag delete _cComment} } proc ctext::comments {win {afterTriggered 0}} { if {[catch {$win tag cget _cComment -foreground}]} { #C comments are disabled return } if {$afterTriggered} { ctext::getAr $win config configAr set configAr(commentsAfterId) "" } set startIndex 1.0 set commentRE {\\\\|\"|\\\"|\\'|'|/\*|\*/} set commentStart 0 set isQuote 0 set isSingleQuote 0 set isComment 0 $win tag remove _cComment 1.0 end while 1 { set index [$win search -count length -regexp $commentRE $startIndex end] if {$index == ""} { break } set endIndex [$win index "$index + $length chars"] set str [$win get $index $endIndex] set startIndex $endIndex if {$str == "\\\\"} { continue } elseif {$str == "\\\""} { continue } elseif {$str == "\\'"} { continue } elseif {$str == "\"" && $isComment == 0 && $isSingleQuote == 0} { if {$isQuote} { set isQuote 0 } else { set isQuote 1 } } elseif {$str == "'" && $isComment == 0 && $isQuote == 0} { if {$isSingleQuote} { set isSingleQuote 0 } else { set isSingleQuote 1 } } elseif {$str == "/*" && $isQuote == 0 && $isSingleQuote == 0} { if {$isComment} { #comment in comment break } else { set isComment 1 set commentStart $index } } elseif {$str == "*/" && $isQuote == 0 && $isSingleQuote == 0} { if {$isComment} { set isComment 0 $win tag add _cComment $commentStart $endIndex $win tag raise _cComment } else { #comment end without beginning break } } } } proc ctext::addHighlightClass {win class color keywords} { set ref [ctext::getAr $win highlight ar] foreach word $keywords { set ar($word) [list $class $color] } $win tag configure $class ctext::getAr $win classes classesAr set classesAr($class) [list $ref $keywords] } #For [ ] { } # etc. proc ctext::addHighlightClassForSpecialChars {win class color chars} { set charList [split $chars ""] set ref [ctext::getAr $win highlightSpecialChars ar] foreach char $charList { set ar($char) [list $class $color] } $win tag configure $class ctext::getAr $win classes classesAr set classesAr($class) [list $ref $charList] } proc ctext::addHighlightClassForRegexp {win class color re} { set ref [ctext::getAr $win highlightRegexp ar] set ar($class) [list $re $color] $win tag configure $class ctext::getAr $win classes classesAr set classesAr($class) [list $ref $class] } #For things like $blah proc ctext::addHighlightClassWithOnlyCharStart {win class color char} { set ref [ctext::getAr $win highlightCharStart ar] set ar($char) [list $class $color] $win tag configure $class ctext::getAr $win classes classesAr set classesAr($class) [list $ref $char] } proc ctext::deleteHighlightClass {win classToDelete} { ctext::getAr $win classes classesAr if {![info exists classesAr($classToDelete)]} { return -code error "$classToDelete doesn't exist" } foreach {ref keyList} [set classesAr($classToDelete)] { upvar #0 $ref refAr foreach key $keyList { if {![info exists refAr($key)]} { continue } unset refAr($key) } } unset classesAr($classToDelete) } proc ctext::getHighlightClasses win { ctext::getAr $win classes classesAr array names classesAr } proc ctext::findNextChar {win index char} { set i [$win index "$index + 1 chars"] set lineend [$win index "$i lineend"] while 1 { set ch [$win get $i] if {[$win compare $i >= $lineend]} { return "" } if {$ch == $char} { return $i } set i [$win index "$i + 1 chars"] } } proc ctext::findNextSpace {win index} { set i [$win index $index] set lineStart [$win index "$i linestart"] set lineEnd [$win index "$i lineend"] #Sometimes the lineend fails (I don't know why), so add 1 and try again. if {[$win compare $lineEnd == $lineStart]} { set lineEnd [$win index "$i + 1 chars lineend"] } while {1} { set ch [$win get $i] if {[$win compare $i >= $lineEnd]} { set i $lineEnd break } if {[string is space $ch]} { break } set i [$win index "$i + 1 chars"] } return $i } proc ctext::findPreviousSpace {win index} { set i [$win index $index] set lineStart [$win index "$i linestart"] while {1} { set ch [$win get $i] if {[$win compare $i <= $lineStart]} { set i $lineStart break } if {[string is space $ch]} { break } set i [$win index "$i - 1 chars"] } return $i } proc ctext::clearHighlightClasses {win} { #no need to catch, because array unset doesn't complain #puts [array exists ::ctext::highlight$win] ctext::getAr $win highlight ar array unset ar ctext::getAr $win highlightSpecialChars ar array unset ar ctext::getAr $win highlightRegexp ar array unset ar ctext::getAr $win highlightCharStart ar array unset ar ctext::getAr $win classes ar array unset ar } #This is a proc designed to be overwritten by the user. #It can be used to update a cursor or animation while #the text is being highlighted. proc ctext::update {} { } proc ctext::highlight {win start end {afterTriggered 0}} { ctext::getAr $win config configAr if {$afterTriggered} { set configAr(highlightAfterId) "" } if {!$configAr(-highlight)} { return } set si $start set twin "$win._t" #The number of times the loop has run. set numTimesLooped 0 set numUntilUpdate 600 ctext::getAr $win highlight highlightAr ctext::getAr $win highlightSpecialChars highlightSpecialCharsAr ctext::getAr $win highlightRegexp highlightRegexpAr ctext::getAr $win highlightCharStart highlightCharStartAr while 1 { set res [$twin search -count length -regexp -- {([^\s\(\{\[\}\]\)\.\t\n\r;\"'\|,]+)} $si $end] if {$res == ""} { break } set wordEnd [$twin index "$res + $length chars"] set word [$twin get $res $wordEnd] set firstOfWord [string index $word 0] if {[info exists highlightAr($word)] == 1} { set wordAttributes [set highlightAr($word)] foreach {tagClass color} $wordAttributes break $twin tag add $tagClass $res $wordEnd $twin tag configure $tagClass -foreground $color } elseif {[info exists highlightCharStartAr($firstOfWord)] == 1} { set wordAttributes [set highlightCharStartAr($firstOfWord)] foreach {tagClass color} $wordAttributes break $twin tag add $tagClass $res $wordEnd $twin tag configure $tagClass -foreground $color } set si $wordEnd incr numTimesLooped if {$numTimesLooped >= $numUntilUpdate} { ctext::update set numTimesLooped 0 } } foreach {ichar tagInfo} [array get highlightSpecialCharsAr] { set si $start foreach {tagClass color} $tagInfo break while 1 { set res [$twin search -- $ichar $si $end] if {"" == $res} { break } set wordEnd [$twin index "$res + 1 chars"] $twin tag add $tagClass $res $wordEnd $twin tag configure $tagClass -foreground $color set si $wordEnd incr numTimesLooped if {$numTimesLooped >= $numUntilUpdate} { ctext::update set numTimesLooped 0 } } } foreach {tagClass tagInfo} [array get highlightRegexpAr] { set si $start foreach {re color} $tagInfo break while 1 { set res [$twin search -count length -regexp -- $re $si $end] if {"" == $res} { break } set wordEnd [$twin index "$res + $length chars"] $twin tag add $tagClass $res $wordEnd $twin tag configure $tagClass -foreground $color set si $wordEnd incr numTimesLooped if {$numTimesLooped >= $numUntilUpdate} { ctext::update set numTimesLooped 0 } } } } proc ctext::linemapToggleMark {win y} { ctext::getAr $win config configAr if {!$configAr(-linemap_markable)} { return } set markChar [$win.l index @0,$y] set lineSelected [lindex [split $markChar .] 0] set line [$win.l get $lineSelected.0 $lineSelected.end] if {$line == ""} { return } ctext::getAr $win linemap linemapAr if {[info exists linemapAr($line)] == 1} { #It's already marked, so unmark it. array unset linemapAr $line ctext::linemapUpdate $win set type unmarked } else { #This means that the line isn't toggled, so toggle it. array set linemapAr [list $line {}] $win.l tag add lmark $markChar [$win.l index "$markChar lineend"] $win.l tag configure lmark -foreground $configAr(-linemap_select_fg) \ -background $configAr(-linemap_select_bg) set type marked } if {[string length $configAr(-linemap_mark_command)]} { uplevel #0 [linsert $configAr(-linemap_mark_command) end $win $type $line] } } #args is here because -yscrollcommand may call it proc ctext::linemapUpdate {win args} { if {[winfo exists $win.l] != 1} { return } set pixel 0 set lastLine {} set lineList [list] set fontMetrics [font metrics [$win._t cget -font]] set incrBy [expr {1 + ([lindex $fontMetrics 5] / 2)}] while {$pixel < [winfo height $win.l]} { set idx [$win._t index @0,$pixel] if {$idx != $lastLine} { set line [lindex [split $idx .] 0] set lastLine $idx lappend lineList $line } incr pixel $incrBy } ctext::getAr $win linemap linemapAr $win.l delete 1.0 end set lastLine {} foreach line $lineList { if {$line == $lastLine} { $win.l insert end "\n" } else { if {[info exists linemapAr($line)]} { $win.l insert end "$line\n" lmark } else { $win.l insert end "$line\n" } } set lastLine $line } set endrow [lindex [split [$win._t index end-1c] .] 0] $win.l configure -width [string length $endrow] } proc ctext::modified {win value} { ctext::getAr $win config ar set ar(modified) $value event generate $win <> return $value } tcltk2/inst/tklibs/ctext3.2/test.c0000644000176000001440000006477212215417550016471 0ustar ripleyusers/*The Panache Window Manager*/ /*By George Peter Staplin*/ /*Please read the LICENSE file included with the Panache distribution *for usage restrictions. */ #include #include #include #ifndef __STDC__ #include #endif #include #include #include #include #include #include #include #include "PanacheWindowList.h" /*Style I use if (returnFromFunc == 1) instead of if (returnFromFunc) I use if (returnFromFunc == 0) instead of if (!returnFromFunc) */ /*Automatic focus of new windows yes/no.*/ /*Automatic focus of transient windows yes/no.*/ #define PANACHE_DIRECTORY "Panache" #define CMD_ARGS (ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) Display *dis; XEvent report; Window root; Tcl_Interp *interp; int distance_from_edge = 0; Window mapped_window = None; int screen; Atom _XA_WM_STATE; Atom _XA_WM_PROTOCOLS; Atom _XA_WM_DELETE_WINDOW; Window workspace_manager; struct CList *keepAboveWindowList; unsigned long eventMask = (ResizeRedirectMask | PropertyChangeMask | \ EnterWindowMask | LeaveWindowMask | FocusChangeMask | KeyPressMask); #define winIdLength 14 /*#define FORK_ON_START*/ int PanacheGetWMState (Window win); void PanacheSelectInputForRootParented (Window win); void PanacheConfigureNormalWindow (Window win, unsigned long value_mask); char Panache_Init_script[] = { "if {[file exists $prefix/$panacheDirectory/Panache.tcl] != 1} {\n" " puts stderr {unable to open Panache.tcl Did you run make install?}\n" " puts stderr \"I looked in $prefix/$panacheDirectory\"\n" " exit -1\n" "}\n" "proc sendToPipe str {\n" " set str [string map {\"\n\" \"\" \"\r\" \"\"} $str]\n" " puts $::pipe $str\n" " flush $::pipe\n" "}\n" "proc getFromPipe {} {\n" " gets $::pipe line\n" " if {$line != \"\"} {\n" " set cmd [lindex $line 0]\n" " if {[llength $line] == 2} {\n" " $cmd [lindex $line 1]\n" " } else {\n" " eval $line\n" " }\n" " }\n" "}\n" "set ::pipe [open \"|$wishInterpreter $prefix/$panacheDirectory/Panache.tcl\" w+]\n" "fconfigure $::pipe -blocking 0\n" "\n"}; char *charMalloc (int size) { char *mem = NULL; mem = (char *) malloc ((sizeof (char)) * size); if (mem == NULL) { fprintf (stderr, "malloc failed to allocate memory This means that Panache \ and other applications could have problems if they continue running.\n\n \ exiting Panache now!"); exit (-1); } return mem; } void sendConfigureNotify (Window win, unsigned long value_mask, XWindowChanges *winChanges) { XEvent xe; XWindowAttributes wattr; if (XGetWindowAttributes (dis, win, &wattr) == 0) { return; } xe.type = ConfigureNotify; xe.xconfigure.type = ConfigureNotify; xe.xconfigure.event = win; xe.xconfigure.window = win; xe.xconfigure.x = (value_mask & CWX) ? winChanges->x : wattr.x; xe.xconfigure.y = (value_mask & CWY) ? winChanges->y : wattr.y; xe.xconfigure.width = (value_mask & CWWidth) ? winChanges->width : wattr.width; xe.xconfigure.height = (value_mask & CWHeight) ? winChanges->height : wattr.height; xe.xconfigure.border_width = 0; xe.xconfigure.above = None; xe.xconfigure.override_redirect = 0; XSendEvent (dis, win, 0, StructureNotifyMask, &xe); XFlush (dis); } void sendMapNotify (Window win) { XEvent mapNotify; mapNotify.type = MapNotify; mapNotify.xmap.type = MapNotify; mapNotify.xmap.window = win; mapNotify.xmap.display = dis; mapNotify.xmap.event = win; XSendEvent (dis, win, 0, StructureNotifyMask, &mapNotify); XFlush (dis); } int PanacheAddAllWindowsCmd CMD_ARGS { Window dummy; Window *children = NULL; unsigned int nchildren; unsigned int i; char *winId; char *transientForWinId; char str[] = "sendToPipe [list add [list $winTitle] $winId $winType $transientForWinId]"; Window twin; XSync (dis, 0); /*XGrabServer (dis);*/ if (XQueryTree (dis, root, &dummy, &dummy, &children, &nchildren) == 0) { fprintf (stderr, "Error querying the tree for the root window.\n"); } for (i = 0; i < nchildren; i++) { XTextProperty xtp; XWMHints *wmHints = XGetWMHints (dis, children[i]); XWindowAttributes wattr; xtp.value = NULL; if (wmHints == NULL) { continue; } if (wmHints->flags & IconWindowHint) { continue; } if (XGetWindowAttributes (dis, children[i], &wattr) == 0) { continue; } if (wattr.override_redirect == 1) { continue; } if (wmHints->flags & StateHint) { if (wmHints->initial_state & WithdrawnState) { continue; } else if (wattr.map_state == 0 && PanacheGetWMState (children[i]) == 0) { continue; } } XFree (wmHints); XGetWMName (dis, children[i], &xtp); winId = charMalloc (winIdLength); sprintf (winId, "%ld", children[i]); Tcl_SetVar (interp, "winTitle", (char *) xtp.value, 0); Tcl_SetVar (interp, "winId", winId, 0); if (XGetTransientForHint (dis, children[i], &twin) == 1) { Tcl_SetVar (interp, "winType", "transient", 0); transientForWinId = charMalloc (winIdLength); sprintf (transientForWinId, "%ld", twin); Tcl_SetVar (interp, "transientForWinId", transientForWinId, 0); free (transientForWinId); PanacheSelectInputForRootParented (children[i]); } else { Tcl_SetVar (interp, "winType", "normal", 0); Tcl_SetVar (interp, "transientForWinId", "", 0); /*Maybe I should compare the first char and then do strcmp?*/ if (xtp.value != NULL && strcmp ((char *)xtp.value, "___Panache_GUI") != 0) { PanacheConfigureNormalWindow (children[i], CWX|CWY|CWWidth|CWHeight); PanacheSelectInputForRootParented (children[i]); } } XFree (xtp.value); free (winId); if (Tcl_Eval (interp, str) != TCL_OK) { fprintf (stderr, "Error in PanacheAddAllWindowsCmd: %s\n", Tcl_GetStringResult (interp)); } } if (children != NULL) { XFree (children); } /*XUngrabServer (dis);*/ XSync (dis, 0); return TCL_OK; } void PanacheConfigureRequest (XConfigureRequestEvent *event) { XWindowChanges wc; Window twin; int maxWidth; int maxHeight; if (event->parent != root) { return; } #ifdef DEBUG fprintf (stderr, "ConfigureRequest win %ld\n", event->window); fprintf (stderr, "CWSibling %d\n", (event->value_mask & CWSibling) == 1); fprintf (stderr, "CWStackMode %d\n", (event->value_mask & CWStackMode) == 1); #endif maxWidth = (DisplayWidth (dis, screen) - distance_from_edge - 4); maxHeight = DisplayHeight (dis, screen); wc.border_width = 0; wc.sibling = None; wc.stack_mode = Above; if (event->window == workspace_manager) { wc.width = distance_from_edge; wc.height = maxHeight; wc.x = 0; wc.y = 0; XConfigureWindow(dis, event->window, CWX|CWY|CWWidth|CWHeight, &wc); sendConfigureNotify (event->window, CWX|CWY|CWWidth|CWHeight, &wc); return; } else { PanacheSelectInputForRootParented (event->window); } if (XGetTransientForHint (dis, event->window, &twin) == 1) { if (event->width > maxWidth) { wc.width = maxWidth; } else { wc.width = event->width; } wc.height = event->height; if (event->x < distance_from_edge) { wc.x = distance_from_edge; } else { wc.x = event->x; } wc.y = event->y; XConfigureWindow (dis, event->window, event->value_mask, &wc); sendConfigureNotify (event->window, event->value_mask, &wc); } else { PanacheConfigureNormalWindow (event->window, event->value_mask); } XFlush (dis); } /*This configures the window and sends a ConfigureNotify event. *It's designed for normal non-transient windows */ void PanacheConfigureNormalWindow ( Window win, unsigned long value_mask) { XWindowChanges wc; XSizeHints sizeHints; long ljunk = 0; int maxWidth = (DisplayWidth (dis, screen) - distance_from_edge - 4); int maxHeight = DisplayHeight (dis, screen); wc.border_width = 0; wc.sibling = None; wc.stack_mode = Above; wc.x = distance_from_edge; wc.y = 0; wc.width = maxWidth; wc.height = maxHeight; if (XGetWMNormalHints (dis, win, &sizeHints, &ljunk)) { if (sizeHints.flags & PMaxSize) { wc.width = (sizeHints.max_width > maxWidth) ? maxWidth : sizeHints.max_width; wc.height = (sizeHints.max_height > maxHeight) ? maxHeight : sizeHints.max_height; #ifdef DEBUG fprintf (stderr, "MaxSize %d %d\n", sizeHints.max_width, sizeHints.max_height); #endif } #ifdef DEBUG if (sizeHints.flags & PResizeInc) { fprintf (stderr, "PResizeInc\n"); fprintf (stderr, "incr %d %d\n", sizeHints.width_inc, sizeHints.height_inc); } if (sizeHints.flags & PAspect) { fprintf (stderr, "PAspect x %d\n", sizeHints.min_aspect.x); } #endif } XConfigureWindow (dis, win, value_mask, &wc); sendConfigureNotify (win, value_mask, &wc); } /*This appends windows that are not to be managed by *Panache to a list, and Panache will later on raise *them above other windows. */ void PanacheCreateNotify (XCreateWindowEvent *event) { if (event->override_redirect == 0 || event->parent != root) { return; } CListAppend (keepAboveWindowList, event->window); } /*X has told Panache that a DestroyNotify event occured *to a child of the root window, so Panache removes the *window from the window list. */ void PanacheDestroyNotify (XDestroyWindowEvent *event) { Window win; char *winId; char str[] = "sendToPipe [list remove $winId]"; win = event->window; winId = charMalloc (winIdLength); sprintf (winId, "%ld", win); Tcl_SetVar (interp, "winId", winId, 0); free (winId); #ifdef DEBUG fprintf (stderr, "DestroyNotify\n"); #endif CListRemove (keepAboveWindowList, event->window); /*Tell Panache_GUI to remove the window*/ if (Tcl_Eval (interp, str) != TCL_OK) { fprintf (stderr, "Tcl_Eval error in PanacheDestroyNotify %s\n", Tcl_GetStringResult (interp)); } } /*Panache_GUI calls this to send WM_DELETE_WINDOW or *invoke XKillClient (if the window doesn't support *WM_DELETE_WINDOW). We can't use XKillClient on all *windows, because if the application has multiple *toplevel windows sending XKillClient would destroy *them all. */ int PanacheDestroyCmd CMD_ARGS { XClientMessageEvent ev; Window win; Atom *wmProtocols = NULL; Atom *protocol; int i; int numAtoms; int handlesWM_DELETE_WINDOW = 0; Tcl_GetLongFromObj (interp, objv[1], (long *) &win); if (XGetWMProtocols (dis, win, &wmProtocols, &numAtoms) == 1) { for (i = 0, protocol = wmProtocols; i < numAtoms; i++, protocol++) { if (*protocol == (Atom)_XA_WM_DELETE_WINDOW) { handlesWM_DELETE_WINDOW = 1; } } if (wmProtocols) { XFree (wmProtocols); } } if (handlesWM_DELETE_WINDOW == 1) { ev.type = ClientMessage; ev.window = win; ev.message_type = _XA_WM_PROTOCOLS; ev.format = 32; ev.data.l[0] = _XA_WM_DELETE_WINDOW; ev.data.l[1] = CurrentTime; XSendEvent (dis, win, 0, 0L, (XEvent *) &ev); } else { XKillClient (dis, win); } XFlush (dis); return TCL_OK; } int PanacheDFECmd CMD_ARGS { Tcl_GetIntFromObj (interp, objv[1], &distance_from_edge); return TCL_OK; } /*Panache_GUI sends focus $winId to get here.*/ int PanacheFocusCmd CMD_ARGS { Window win; Tcl_GetLongFromObj (interp, objv[1], (long *) &win); if (XSetInputFocus (dis, win, RevertToParent, CurrentTime) != 1) { fprintf (stderr, "XSetInputFocus failure within PanacheFocusCmd()"); } XFlush (dis); return TCL_OK; } int PanacheGetWMState (Window win) { int returnValue = 0; Atom type; int ijunk; unsigned long ljunk; unsigned long *state = NULL; XGetWindowProperty ( dis, win, _XA_WM_STATE, 0L, 1L, 0, _XA_WM_STATE, &type, &ijunk, &ljunk, &ljunk, (unsigned char **) &state ); if (type == _XA_WM_STATE) { returnValue = (int) *state; } else { /*Don't know what to do*/ returnValue = 0; } if (state != NULL) { XFree (state); } return returnValue; } /*A window to keep above has the override_redirect *attribute set to 1. */ void PanacheRaiseKeepAboveWindows () { Window win; CListRewind (keepAboveWindowList); while ((win = CListGet (keepAboveWindowList)) != NULL) { XRaiseWindow (dis, win); } XFlush (dis); } void PanacheRecursivelyGrabKey (Window win, int keycode) { Window dummy; Window *children = NULL; unsigned int nchildren; int i; if (XQueryTree (dis, win, &dummy, &dummy, &children, &nchildren) == 0) { return; } for (i = 0; i < nchildren; i++) { PanacheRecursivelyGrabKey (children[i], keycode); XGrabKey (dis, keycode, Mod1Mask, win, 1, GrabModeAsync, GrabModeSync); } if (children != NULL) { XFree (children); } } int PanacheReparentCmd CMD_ARGS { Window newParent; Window win; Tcl_GetLongFromObj (interp, objv[1], (long *) &win); Tcl_GetLongFromObj (interp, objv[2], (long *) &newParent); XReparentWindow (dis, win, newParent, 0, 20); return TCL_OK; } void PanacheSelectInputForRootParented (Window win) { XSelectInput (dis, win, eventMask); } void PanacheSetWMState (Window win, int state) { unsigned long data[2]; data[0] = state; data[1] = None; XChangeProperty (dis, win, _XA_WM_STATE, _XA_WM_STATE, 32, PropModeReplace, (unsigned char *) data, 2 ); XSync (dis, 0); } int PanacheTransientCmd CMD_ARGS { Window parent; Window win; Tcl_GetLongFromObj (interp, objv[1], (long *) &win); Tcl_GetLongFromObj (interp, objv[2], (long *) &parent); XSetTransientForHint (dis, win, parent); return TCL_OK; } /*This sends a string to Panache_GUI with info about the window, *such as its title and window id. This information is processed *within Panache_GUI and if desired PanacheMapCmd will map the *window. */ void PanacheMapRequest (XMapRequestEvent *event) { char *winId; char *transientForWinId; XTextProperty xtp; char str[] = "sendToPipe [list add [list $winTitle] $winId $winType $transientForWinId]"; Window twin; if (event->window == NULL) { return; } /*This makes the state iconic, so that if the user presses *restart before mapping the window, the window will show up. */ PanacheSetWMState (event->window, IconicState); xtp.value = NULL; XGetWMName (dis, event->window, &xtp); winId = charMalloc (winIdLength); sprintf (winId, "%ld", event->window); PanacheSelectInputForRootParented (event->window); Tcl_SetVar (interp, "winTitle", (char *) xtp.value, 0); Tcl_SetVar (interp, "winId", winId, 0); if (XGetTransientForHint (dis, event->window, &twin) == 1) { Tcl_SetVar (interp, "winType", "transient", 0); transientForWinId = charMalloc (winIdLength); sprintf (transientForWinId, "%ld", twin); Tcl_SetVar (interp, "transientForWinId", transientForWinId, 0); free (transientForWinId); } else { Tcl_SetVar (interp, "winType", "normal", 0); Tcl_SetVar (interp, "transientForWinId", "", 0); } XFree (xtp.value); free (winId); if (Tcl_Eval (interp, str) != TCL_OK) { fprintf (stderr, "Error in PanacheMapRequest: %s\n", Tcl_GetStringResult (interp)); } } /*This maps a window. It may be called after PanacheMapRequest by *Panache_GUI. This is also called when a window is over another *window and the user selects the button for the window to display *which causes this function to raise the window. */ int PanacheMapCmd CMD_ARGS { Window win; Window twin; XWindowAttributes winAttrib; Tcl_GetLongFromObj (interp, objv[1], (long *) &win); PanacheSelectInputForRootParented (win); /*XGrabKey (dis, XK_Tab, Mod1Mask, win, 1, GrabModeAsync, GrabModeAsync);*/ /*PanacheRecursivelyGrabKey (win, XK_Tab);*/ XGetWindowAttributes (dis, win, &winAttrib); if (winAttrib.x < distance_from_edge) { winAttrib.x = distance_from_edge; if (winAttrib.y < 0) { winAttrib.y = 0; } XMoveWindow (dis, win, winAttrib.x, winAttrib.y); } if (XGetTransientForHint (dis, win, &twin) == 1) { PanacheSetWMState (win, NormalState); XMapRaised (dis, win); sendMapNotify (win); mapped_window = win; PanacheRaiseKeepAboveWindows (); return TCL_OK; } if ((PanacheGetWMState (win)) == 1) { XRaiseWindow (dis, win); PanacheRaiseKeepAboveWindows (); return TCL_OK; } /*If we are here the window hasn't had its size set, or *the WM_STATE was not 1. */ PanacheSetWMState (win, NormalState); /*I've found that some applications get upset if you sent *a ConfigureNotify before the MapNotify, when they are *expecting the MapNotify to be eminent. */ XMapRaised (dis, win); sendMapNotify (win); PanacheConfigureNormalWindow (win, CWX|CWY|CWWidth|CWHeight); mapped_window = win; PanacheRaiseKeepAboveWindows (); return TCL_OK; } int PanacheMapWorkspaceCmd CMD_ARGS { XWindowChanges wc; Window win; Tcl_GetLongFromObj (interp, objv[1], (long *) &win); workspace_manager = win; PanacheSetWMState (win, NormalState); wc.x = 0; wc.y = 0; wc.width = distance_from_edge; wc.height = DisplayHeight (dis, screen); XConfigureWindow(dis, win, CWX|CWY|CWWidth|CWHeight, &wc); sendConfigureNotify (win, CWX|CWY|CWWidth|CWHeight, &wc); XMapWindow (dis, win); sendMapNotify (win); mapped_window = win; XFlush (dis); return TCL_OK; } int PanacheMoveCmd CMD_ARGS { XEvent event; unsigned int buttonPressed; Window wjunk; int ijunk; Cursor handCursor; Window win; int oldX; int oldY; int x; int y; int internalX; int internalY; unsigned int maskReturn; int continueEventLoop = 1; XWindowAttributes winAttr; handCursor = XCreateFontCursor (dis, XC_hand2); XGrabPointer (dis, root, 1, ButtonPressMask | ButtonReleaseMask | ButtonMotionMask | \ PointerMotionHintMask, GrabModeAsync, GrabModeAsync, None, handCursor, CurrentTime ); /*Wait until the user has selected the window to move.*/ XMaskEvent (dis, ButtonPressMask, &event); /*The button being held down while dragging the window.*/ buttonPressed = event.xbutton.button; /*fprintf (stderr, "ButtonPressed %d\n", buttonPressed);*/ XQueryPointer (dis, root, &wjunk, &win, &oldX, &oldY, &internalX, &internalY, &maskReturn ); if (win == workspace_manager) { XUngrabPointer (dis, CurrentTime); XFreeCursor (dis, handCursor); XSync (dis, 0); return TCL_OK; } XGetWindowAttributes (dis, win, &winAttr); while (continueEventLoop == 1) { XNextEvent (dis, &event); switch (event.type) { case ButtonRelease: { if (event.xbutton.button == buttonPressed) { continueEventLoop = 0; } } break; case MotionNotify: { XWindowChanges wc; int newX; int newY; while (XCheckTypedEvent (dis, MotionNotify, &event)); XQueryPointer (dis, root, &wjunk, &wjunk, &x, &y, &ijunk, &ijunk, &maskReturn ); newX = x - oldX + winAttr.x; newY = y - oldY + winAttr.y; if (newX < distance_from_edge) { if (winAttr.override_redirect == 1) { XMoveWindow (dis, win, distance_from_edge, newY); } else { wc.x = distance_from_edge; wc.y = newY; XConfigureWindow (dis, win, CWX | CWY, &wc); sendConfigureNotify (win, CWX | CWY, &wc); } continue; } if (winAttr.override_redirect == 1) { XMoveWindow (dis, win, newX, newY); } else { wc.x = newX; wc.y = newY; XConfigureWindow (dis, win, CWX | CWY, &wc); sendConfigureNotify (win, CWX | CWY, &wc); } } break; } } /*fprintf (stderr, "win is %ld\n", win);*/ XUngrabPointer (dis, CurrentTime); XFreeCursor (dis, handCursor); XSync (dis, 0); return TCL_OK; } XErrorHandler PanacheErrorHandler (Display *dis, XErrorEvent *event) { /*I've discovered that errors are frequently timing problems. Maybe XSync would help in some areas. Most errors are not fatal. */ return 0; } int main() { fd_set readfds; int nfds; int xFd; int pipeFd; int inputPipeFd; ClientData data; int fdsTcl; dis = XOpenDisplay (NULL); screen = DefaultScreen (dis); root = RootWindow (dis, screen); interp = Tcl_CreateInterp (); XSetErrorHandler ((XErrorHandler) PanacheErrorHandler); _XA_WM_STATE = XInternAtom (dis, "WM_STATE", 0); _XA_WM_PROTOCOLS = XInternAtom (dis, "WM_PROTOCOLS", 0); _XA_WM_DELETE_WINDOW = XInternAtom (dis, "WM_DELETE_WINDOW", 0); keepAboveWindowList = CListInit (); #ifdef FORK_ON_START { int res; res = fork(); if (res == -1) { fprintf (stderr, "Unable to fork process."); return 1; } if (res != 0) { exit (0); } } #endif if (Tcl_Init (interp) != TCL_OK) { printf ("Tcl_Init error\n"); exit (-1); } #define CREATE_CMD(cmdName,func) Tcl_CreateObjCommand (interp, \ cmdName, func, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL) CREATE_CMD ("map_workspace", PanacheMapWorkspaceCmd); CREATE_CMD ("distance_from_edge", PanacheDFECmd); CREATE_CMD ("map", PanacheMapCmd); CREATE_CMD ("destroy", PanacheDestroyCmd); CREATE_CMD ("add_all_windows", PanacheAddAllWindowsCmd); CREATE_CMD ("focus", PanacheFocusCmd); CREATE_CMD ("transient", PanacheTransientCmd); CREATE_CMD ("reparent", PanacheReparentCmd); CREATE_CMD ("move", PanacheMoveCmd); Tcl_SetVar (interp, "wishInterpreter", WISH_INTERPRETER, 0); Tcl_SetVar (interp, "prefix", PREFIX, 0); Tcl_SetVar (interp, "panacheDirectory", PANACHE_DIRECTORY, 0); if (Tcl_Eval (interp, Panache_Init_script) != TCL_OK) { fprintf (stderr, "Error while evaluating Panache_Init_script within main()%s\n", Tcl_GetStringResult (interp)); exit (-1); } XSelectInput (dis, root, LeaveWindowMask | EnterWindowMask| \ PropertyChangeMask | SubstructureRedirectMask | \ SubstructureNotifyMask | KeyPressMask | KeyReleaseMask | \ ResizeRedirectMask | FocusChangeMask ); xFd = ConnectionNumber (dis); Tcl_GetChannelHandle (Tcl_GetChannel (interp, Tcl_GetVar (interp, "pipe", NULL), NULL), TCL_WRITABLE, &data); pipeFd = (int) data; /*fprintf (stderr, "pipeFd %d", pipeFd);*/ Tcl_GetChannelHandle (Tcl_GetChannel (interp, Tcl_GetVar (interp, "pipe", NULL), NULL), TCL_READABLE, &data); inputPipeFd = (int) data; XFlush(dis); for (;;) { FD_ZERO (&readfds); FD_SET (xFd, &readfds); FD_SET (pipeFd, &readfds); FD_SET (inputPipeFd, &readfds); fdsTcl = (pipeFd > inputPipeFd) ? pipeFd : inputPipeFd; nfds = (xFd > fdsTcl) ? xFd + 1: fdsTcl + 1; select (nfds, &readfds, NULL, NULL, NULL); if (FD_ISSET (inputPipeFd, &readfds) != 0) { if (Tcl_Eval (interp, "getFromPipe") != TCL_OK) { fprintf (stderr, "getFromPipe error %s\n", Tcl_GetStringResult (interp)); } } if (FD_ISSET (pipeFd, &readfds) != 0) { while (Tcl_DoOneEvent (TCL_DONT_WAIT)); } if (FD_ISSET (xFd, &readfds) == 0) { continue; } while (XPending (dis) > 0) { XNextEvent (dis, &report); /*fprintf (stderr, "type %d\n", report.type);*/ switch (report.type) { case ConfigureNotify: /*fprintf (stderr, "ConfigureNotify \n");*/ break; case CreateNotify: PanacheCreateNotify (&report.xcreatewindow); break; case ConfigureRequest: PanacheConfigureRequest (&report.xconfigurerequest); break; case DestroyNotify: PanacheDestroyNotify (&report.xdestroywindow); break; case EnterNotify: { Window win = report.xcrossing.window; char *winId = NULL; char cmd[] = "sendToPipe [list activateWindow $winId]"; winId = charMalloc (winIdLength); sprintf (winId, "%ld", win); Tcl_SetVar (interp, "winId", winId, 0); free (winId); if (Tcl_Eval (interp, cmd) != TCL_OK) { fprintf (stderr, "Error evaluating cmd in EnterNotify within main() %s\n", Tcl_GetStringResult (interp)); } } break; case FocusIn: break; case KeyPress: { char cmd[] = "sendToPipe next"; if (XLookupKeysym (&report.xkey, 0) == XK_Tab && (report.xkey.state & Mod1Mask)) { fprintf (stderr, "alt tab win %ld\n", report.xkey.window); if (Tcl_Eval (interp, cmd) != TCL_OK) { fprintf (stderr, "Error evaluating cmd in KeyPress within main() %s\n", Tcl_GetStringResult (interp)); } } else { /*Send XK_Tab*/ } /* fprintf (stderr, "1 %d \n", report.xkey.state == Mod1Mask); fprintf (stderr, "2 %d \n", report.xkey.state == Mod2Mask); fprintf (stderr, "3 %d \n", report.xkey.state == Mod3Mask); fprintf (stderr, "4 %d \n", report.xkey.state == Mod4Mask); fprintf (stderr, "5 %d \n", report.xkey.state == Mod5Mask); */ } break; case MapRequest: PanacheMapRequest (&report.xmaprequest); break; case UnmapNotify: { int state = PanacheGetWMState (report.xunmap.window); /*Mapped or Iconified*/ if (state == 1 || state == 3) { char *winId = NULL; char cmd[] = "sendToPipe [list remove $winId]"; winId = charMalloc (winIdLength); sprintf (winId, "%ld", report.xunmap.window); Tcl_SetVar (interp, "winId", winId, 0); free (winId); PanacheSetWMState (report.xunmap.window, WithdrawnState); if (Tcl_Eval (interp, cmd) != TCL_OK) { fprintf (stderr, "Tcl_Eval error in UnmapNotify within main() %s", Tcl_GetStringResult (interp)); } } } break; case PropertyNotify: { XTextProperty xtp; xtp.value = NULL; if (XGetWMName (dis, report.xproperty.window, &xtp) == 1) { char *winId; char cmd[] = "sendToPipe [list title [list $winTitle] $winId]"; winId = charMalloc (winIdLength); sprintf (winId, "%ld", report.xproperty.window); Tcl_SetVar (interp, "winTitle", (char *) xtp.value, 0); Tcl_SetVar (interp, "winId", winId, 0); free (winId); XFree (xtp.value); if (Tcl_Eval (interp, cmd) != TCL_OK) { fprintf (stderr, "Tcl_Eval error in PropertyNotify: within main() %s\n", Tcl_GetStringResult (interp)); } } } break; case ReparentNotify: { Window win = report.xreparent.window; Window parent = report.xreparent.parent; /* fprintf (stderr, "ReparentNotify\n"); fprintf (stderr, "win %ld parent %ld event %ld\n", win, parent, event); */ XSelectInput (dis, win, 0); if (parent != root) { char *winId; char cmd[] = "sendToPipe [list remove $winId]"; winId = charMalloc (winIdLength); sprintf (winId, "%ld", win); Tcl_SetVar (interp, "winId", winId, 0); free (winId); if (Tcl_Eval (interp, cmd) != TCL_OK) { fprintf (stderr, "Tcl_Eval error in ReparentNotify within main() %s\n", Tcl_GetStringResult (interp)); } } } break; case ResizeRequest: { Window twin; Window win = report.xresizerequest.window; if (XGetTransientForHint (dis, win, &twin) == 1) { XResizeWindow (dis, win, report.xresizerequest.width, report.xresizerequest.height ); } XFlush (dis); } break; default: break; } } } return 0; } tcltk2/inst/tklibs/ctext3.2/ctext_tcl.tcl0000644000176000001440000000376112215417550020032 0ustar ripleyusers# RCS: @(#) $Id: ctext_tcl.tcl,v 1.2 2005/03/31 03:15:48 andreas_kupries Exp $ package provide ctext_tcl 0.8 proc ctext::setHighlightTcl {w} { set color(widgets) red3 set color(flags) orange3 set color(stackControl) red set color(vars) magenta4 set color(variable_funcs) red4 set color(brackets) DeepPink set color(comments) blue4 set color(strings) green4 ctext::addHighlightClass $w widgets $color(widgets) \ [list obutton button label text frame toplevel cscrollbar \ scrollbar checkbutton canvas listbox menu menubar menubutton \ radiobutton scale entry message tk_chooseDir tk_getSaveFile \ tk_getOpenFile tk_chooseColor tk_optionMenu] ctext::addHighlightClass $w flags $color(flags) \ [list -text -command -yscrollcommand \ -xscrollcommand -background -foreground -fg -bg \ -highlightbackground -y -x -highlightcolor -relief -width \ -height -wrap -font -fill -side -outline -style -insertwidth \ -textvariable -activebackground -activeforeground \ -insertbackground -anchor -orient -troughcolor -nonewline \ -expand -type -message -title -offset -in -after -yscroll \ -xscroll -forward -regexp -count -exact -padx -ipadx \ -filetypes -all -from -to -label -value -variable \ -regexp -backwards -forwards -bd -pady -ipady -state -row \ -column -cursor -highlightcolors -linemap -menu -tearoff \ -displayof -cursor -underline -tags -tag -length] ctext::addHighlightClass $w stackControl $color(stackControl) \ [list proc uplevel namespace while for foreach if else] ctext::addHighlightClassWithOnlyCharStart $w vars $color(vars) "\$" ctext::addHighlightClass $w variable_funcs $color(variable_funcs) \ [list set global variable unset] ctext::addHighlightClassForSpecialChars $w brackets $color(brackets) {[]{}} ctext::addHighlightClassForRegexp $w comments $color(comments) {\#[^\n\r]*} ctext::addHighlightClassForRegexp $w strings $color(strings) {"(\\"|[^"])*"} } tcltk2/inst/tklibs/ctext3.2/ChangeLog0000644000176000001440000004753512215417550017116 0ustar ripleyusers2009-01-21 Andreas Kupries * * Released and tagged Tklib 0.5 ======================== * 2008-08-19 George Peter Staplin ctext.tcl: I fixed bug 2059415 by saving the id from [after idle]. On widget destruction the ids are catch {after cancel}. I also fixed an old bug that occured in the tests, with backspace, and the previously highlighted text not being dehighlighted. pkgIndex.tcl: I bumped the revision to 3.2 ctext.man: Updated to revision 3.2 2007-05-11 Jeff Hobbs * ctext.tcl (ctext::linemapUpdate): make the ctext linemap not resize - it maintains the widest size necessary 2006-10-01 Arjen Markus ctext.man updated - -linemap clarified, example reformatted (smaller width, for better display and printing), added configure subcommand 2005-11-10 Andreas Kupries * * Released and tagged Tklib 0.4.1 ======================== * 2005-11-02 Andreas Kupries * * Released and tagged Tklib 0.4 ======================== * 2005-04-07 Andreas Kupries * ctext.man: Fixed formatting bugs in ctext.man 3.1.6 - Wed Apr 6 04:41:13 GMT 2005 ctext.man was kindly contributed by Michael Schlenker. Thanks Michael :) 3.1.5 - Mon Mar 21 11:23:09 GMT 2005 ctext_tcl.tcl was contributed to ctext by Uwe Koloska. It provides easy syntax highlighting for Tcl scripts. He has apparently added ctext to Nagelfar. http://spjuth.pointclark.net/Nagelfar.html 3.1.4 - Thu Aug 12 03:10:06 UTC 2004 ctext.tcl was changed to fix a bug that occured when the geometry management of the ctext widget was such that it wouldn't enlarge when [$inst configure -linemap 1] was invoked. This was fixed using grid and a -minsize. The previous manager was pack. Grid behaves in an appropriate manner for this situation with the proper weights and -minsize. Thanks to Arjen Markus for testing and bringing this up. 3.1.3 - Thu Jan 22 14:51:08 GMT 2004 I changed the bindtags so that binding to the parent frame will cause the child $win.t to invoke those bindings. This means that you can create menus that popup on ButtonPress-3 without having to use bind.tree or a similar mechanism. Thank Jeff Hobbs for pointing this out. I fixed the destroy event handling, so that it will now not cleanup the widget when a temporary child of the widget is destroyed. 3.1.2 - Fri May 23 17:33:17 GMT 2003 I fixed ctext::deleteHighlighClass so that it will now delete regexp classes. I had to modify ctext::getHighlightClasses and ctext::addHighlightClassForRegexp to fix it. I've decided to keep the package provide at 3.1. 3.1.1 - Fri May 23 00:53:39 GMT 2003 I made some minor changes to configure instance handling, so that .t config will return the proper values. Alas I decided to add a TODO, because the values aren't quite like standard Tk; with the resource classes and all. 3.1 - Thu May 22 01:30:41 GMT 2003 I fixed some bugs on the configure instance handling. I added ctext::buildArgParseTable, which improves performance, because now the table is only generated once per widget. I improved cget to accept glob expressions, which also fixed a bug with strings like: cget -yscroll which didn't match an array element, but do match when passed to the real text widget. You can now pass strings like: .t config -flag and the value for -flag will be returned even if the flag is special to ctext. This took some engineering to get right. I fixed a bug in the test files that occured due to some fixes. Basically I'm using list now to construct the tagInfo for each highlight class. This caused problems, because I was previously using strings. The test files were using escapes to work around the quoting problem. They have been changed and now everything should work properly. You will need to lookout for this problem if you upgrade. I updated REGRESSION. The end result is a good release based on my testing. 3.1-alpha-5 - Thu May 15 00:39:10 GMT 2003 I fixed a minor bug in argument handling in the configure instance handler. 3.1-alpha-4 - Wed May 14 17:09:32 GMT 2003 I improved install.tcl by adding more information about auto_path. I fixed a bug with listbox selection in install.tcl (curselection wasn't used). I renamed ctext::getClasses to ctext::getHighlightClasses. I made some uplevel calls list based, so that if $win has a space in its path ctext will work correctly. I made the class creation procs all use list for storing items in the arrays. I modified ctext::getHighlightClasses to return a list in the format of: class [list items ...] I fixed a bug with ctext::addHighlightClassForRegexp. It wasn't storing the $re in the class array. This was new to the 3.x series. 3.1-alpha-2-3 - Tue May 13 19:30:51 GMT 2003 I have redone the configure instance handling. I added -linemap_select_fg and -linemap_select_bg. I have updated the README to reflect the new commands and options introduced in the 3.x series. I have removed the TODO file, because all tasks within it have been completed. I added an install.tcl script. It's very easy to use and passes all of my tests. I need to test with Malephiso, because there may be minor issues I haven't noticed. 3.1-alpha-1 - Mon May 12 23:12:18 GMT 2003 I've made many changes that have cleaned up the code. I have added -linemap_markable. I changed ctext::getAr to accept a suffix. I'm now using global variables with a __ctext prefix, because it is easier than using namespace variables. The _blink tag was renamed to __ctext_blink. I added ctext::deleteHighlightClass, which works with any of the 4 class creators. It needs more testing, but so far it passes all of my tests. I want to wait about a week or so and go over each line of code slowly. I've tried to engineer this well, but typos happen, so... I need to merge more of Andreas Sievers' changes and features. [At this point Andreas Sievers working on ASED submitted his 3.0 to me and I decided to create 3.1 which merges 2.7-alpha with his work.] 2.7-alpha - Fri May 2 13:08:48 GMT 2003 I have added -linemap_mark_command with an example in ctext_test_interactive.tcl I addec ctext::getAr which I'm using to store more state information about the widget for cget and configure. I modified cget and configure to use it, and they are now more useful. This is an alpha release because I haven't tested it much. I still need to spend some time and review the diffs. I'll probably get to that next week, and I'll test it with Malephiso (my editor). I should also update the README with information about -linemap_mark_command. 2.6.10 - Tue Apr 29 20:47:29 GMT 2003 I fixed a bug with -font handling in the instance command. You can now do: .t config -font and it will change the linemap font as well as the main text widget. I cleaned up argument handling in the constructor and instance commands. They now use concat and are simpler. I added ctext::event:Destroy which now takes care of removing an interp alias which was missing in previous releases. interp alias is now used rather than eval with a dummy proc for creating an instance command. $win now has a binding that should fix a problem some of you may experience. You can now do: focus $win and it will act like: focus $win.t I removed uplevel n eval calls, which were pointless. I didn't realize when I wrote them that uplevel acts like eval. 2.6.9 - Mon Apr 28 16:17:13 GMT 2003 I fixed a minor focus issue by adding -takefocus 0 to the linemap creator. I also removed an uplevel #0 for interp alias, which wasn't needed. I removed the government clause in the LICENSE. I'm pondering a rewrite of Ctext (yet again) which will use SDynObject, and provide more features, but the thought "Why fix it if it isn't broken?" comes to mind. 2.6.8 - Mon Dec 2 18:24:49 GMT 2002 I fixed two bugs pointed out by Neil Madden. The initial creation of the widget failed when -linemap 0 was used. The virtual event <> was not occuring. ---- I cleaned up several rough areas in the code. I cleaned up the code in the creation of the widget for -yscrollcommand and the linemap. I cleaned up the code in the configure instance command handler. ---- This release passes all of my tests with Tcl/Tk 8.3 and 8.4. To make debugging easier I have added ctext_test_interactive.tcl 2.6.7 - Fri Nov 22 16:39:41 GMT 2002 I fixed a bug with C comment highlighting. It wasn't updating the highlighting when the insertion was just one character. The problem was that the RE didn't match, because the previous char and next char were not used to decipher the match. This release was tested with Tcl/Tk 8.4 2.6.6 - Thu Aug 22 23:46:14 GMT 2002 I fixed a serious bug with ctext::matchPair and ctext::matchQuote. The problem was that in some cases the pattern )|}|] was causing an infinite loop when no other patterns matched. It was finding the same character over and over again. This is fixed now. I'm sorry to anyone that was bothered by this. I found it today with Malephiso while editing a test file. It basically locked up my editor. The long scripts and C code I've been editing in the past haven't had this problem, due to multiple characters matching. Please report BUGS. I need your help. 2.6.5 - Tue Aug 20 23:27:23 GMT 2002 I fixed a minor issue with handling. A catch was needed to prevent an error message, due to several events occuring in some cases. 2.6.4 - Tue Jul 23 19:29:49 MDT 2002 I fixed a minor bug with the linemap updating. I didn't notice that with a small number of lines it wasn't displaying the line numbers properly. I fixed a major flaw with 8.4 handling. The 8.4 text widget has some new features, and the edit instance command wasn't dealing with the requests properly. Now it should, but I haven't tested it a lot. 2.6.3 - Fri Jul 5 11:32:42 MDT 2002 I made improvements to ctext::matchPair that should improve the speed. I also fixed a bug that occured with the pattern { \}. I added an edit modified instance command. I'm not sure if it works like the Tk 8.4 version, but it should work well enough. I added edit modified tests to ctext_test.tcl I added -class Ctext to the parent frame. Those of you using .Xdefaults may want this. I updated the README for edit modified. It's about time for another study session of the code to fix any bugs or potential bugs. 2.6.2 - Mon Jul 1 09:31:39 MDT 2002 I fixed a bug with handling. I removed all calls to variable, and now use the fully qualified namespace name for variables. This makes the code more concise and cleaner. I improved the speed of ctext::addHighlightClassForSpecialChars by using foreach with [split $str ""]. I added a Destroy button to ctext_test.tcl. I removed the -font flags in the test files, so it will use what's in the X resources, or the default for Tk. I improved ctext::matchQuote:blink by doing if {$count & 1} rather than if {[expr {$count & 1}]} I need to remember that if is like expr. I fixed a Doh! in ctext::matchQuote. I was not thinking that the end pos is already known due to the switch in the instanceCmd. ctext::matchPair now works. Try typing a pattern of ( ) or [ ] or { } or ( ( ) ) and so on. It's really cool. Big thanks to Mac Cody for inspiring this. I didn't use any of his code for MatchPair but I looked at it to get a general idea. 2.6.1 - Thu Jun 27 10:55:54 MDT 2002 I added ctext::disableComments and ctext::enableComments. C comment highlighting is disabled by default now. I started merging the changes by Mac Cody into this release. I used some of his code for making quotes blink. I rewrote some of it to fit more with my ideals. I'll be merging more of his great ideas into Ctext in the future. I fixed a bug with the C comment highlighting. I found that \\ was causing problems, so the \\\\ RE addition and \\\\ check solves that. I replaced func_finder.tcl with a newer file that should work better. What I should probably do is write a minimal C parser for dealing with finding functions, or do another trick with the C preprocessor. I updated the README and ctext_test_c.tcl 2.6 - Mon Jun 24 09:39:24 MDT 2002 I radically modified ctext::comments to fix bugs with comments in quotes being highlighted and to improve speed. It is now much faster and simpler. I added -linemapfg and -linemapbg options. 2.5.2 - Sun May 19 09:36:16 MDT 2002 I made major changes to how the C commenting works. I made a serious mistake with the way that C comments were highlighted. I was invoking ctext::comments and there could be several after idle timers going that call it that were relying on a global array. Basically my state variables were getting clobbered. It took me a while to figure this out. Now I pass a [clock clicks] argument for each call and it creates the array if necessary and passes the clock clicks value in subsequent calls. The end result is that now several ctext::comments loops can be running at once and they don't clobber each other. 2.5.1 - Fri Mar 15 17:15:30 MST 2002 I have added ctext::update which allows you to update a cursor or progress dialog while Ctext highlights text. It works quite nicely in Malephiso. I updated the README to show the new change, and how to use it. I also fixed a minor error in the README. 2.5 - Sat Mar 2 23:59:07 MST 2002 I've fixed several critical bugs with deletion of text. I've improved the clarity of the code by adding ctext::instanceCmd. This also makes it so that theoretically you could overload ctext. The performance of deletion and insertion may be better due to my use of a timer for highlighting. 2.4.1 - Sat Feb 23 23:12:49 MST 2002 I fixed a bug with tag removal that occured when text was appended to an existing tag. The fix was to use the insert position minus one char in the call to ctext::findPreviousSpace. 2.4 - Tue Feb 5 16:27:46 MST 2002 The linemap will now update even if scrolling hasn't occured. I tried to get this working in previous releases, but had problems with display updates. Now I use "after 1" with it, so it works without blocking the GUI. The widget should now completely clean up after itself I hope. I made changes to the callback. Please let me know if it doesn't cleanup for you. 2.3.5 - Wed Jan 23 23:55:51 MST 2002 I fixed a minor bug that caused some text tags to be removed when they shouldn't be when deleting the first character of a line. if {[$self._t compare $start < $lineStart]} { set start $lineStart } 2.3.4 - Mon Jan 21 22:05:23 MST 2002 I added | and , to the not chars. This helps with C syntax highlighting. 2.3.3 - Mon Jan 14 23:06:39 MST 2002 I fixed a bug with C comment highlighting that occured when the state of the comment handler was not reset when it reached the end of the text widget. I also fixed a minor bug with tag removal in the delete handler. 2.3.2 - Thu Jan 10 19:48:20 MST 2002 I added " and ' to the not chars in the main highlighting engine. This makes it so that char start strings like $blah end at a " or '. So, for example with $blah" every thing would be highlighted like the variable. Now, it only highlights the $blah. 2.3.1 - Fri Jan 4 22:35:19 MST 2002 I fixed a minor bug with the C comment handling. I now have it working very fast for a while, and then it stops until being restarted when / or * is found/entered in the insert or delete widget instance commands. There is one bug I'm trying to track down where the highlighting stops for apparently no reason. It's probably good enough to use for production use in Malephiso, but as usual no warranty to you folks. 2.3 - Mon Dec 31 15:18:05 MST 2001 I have added C comment highlighting. It works properly but it flashes; which can be annoying. I'm going to work on this more later on. 2.2.8 - Mon Dec 31 04:18:57 MST 2001 I fixed some bugs with the delete instance command. 2.2.7 - Sun Dec 30 18:15:10 MST 2001 I made changes to ctext::highlight that have improved the speed. They should help a lot with very large files. 2.2.6 - Sun Dec 30 16:28:26 MST 2001 I improved the search expressions by adding -- to deal with - in any of the search strings. Using ctext in Malephiso has caused me to find so many bugs that I had no idea about over the past week or so. 2.2.5 - Sun Dec 30 11:10:38 MST 2001 I fixed a bug with findPreviousSpace and findNextSpace which should improve the speed of tag removal, because it will no longer remove char tags that it doesn't have to. 2.2.4 - Sun Dec 30 10:57:57 MST 2001 I fixed a bug with the highlighting that occured when the whitespace is entered between a highlighted word. I also fixed a bug with the linemap that occured when an empty line was pressed. 2.2.3 - Mon Dec 24 12:53:49 MST 2001 I added ; to the RE for not chars in the ctext::highlight proc. 2.2.2 - Sun Dec 23 14:37:26 MST 2001 I made a minor change to the highlighting RE, so that it handles things like [.widget cget -flag] Before this the -flag part wouldn't have been highlighted. I added ctext::clearHighlightClasses which takes only one argument; $win. 2.2.1 - Wed Dec 19 10:18:42 MST 2001 I fixed a bug that occured with some text widget commands, for example searching with -count. I had to use uplevel in the call to the master text widget. 2.2 - Wed Dec 19 06:18:08 MST 2001 I've fixed some bugs that occured if C functions were being highlighted. I changed addHighlightClassForSpecialChars so that it accepts a string of characters to match. All addHighlightClass commands now must have a window argument. The window argument makes it so that you can now have multiple languages highlighted in separate windows. I added ctext::addHighlightClassForRegexp (see the test files for examples). I'm going to write a script for finding all Tcl and Tk flags via an automated search through the man pages. This should hopefully help others with their custom editors that use ctext. 2.1.4 I fixed a few bugs. Widget destruction should now work properly. 2.1.3: Well, the diff between 2.1.2 and 2.1.3 is huge. To summarize I've replaced the list that stored selected linemap lines with an array, which has improved the performance. I've added error checking and done a bunch of cleanup. I've changed the indentation style. 2.1.2: LICENSE file added and licensing changed to BSD style. 2.1.1: replaced addHighlightClass array setting with a list (quoting hell fix) 2.1: added \r to the tests for the Mac added \r to the default regexp end of line for the Mac removed global and replaced with upvar #0 added ctext to the prefix of ToggledList new ctext_test2.tcl with two ctext widgets fixed the dos2unix script, so that {lf lf} -translation is used 2.0.2: fixed a bug with insert calling highlight improperly when pasting/inserting multiple lines wrote dos2unix to convert from NT's \r\n to \n so that Unix people aren't annoyed. update idletasks added to delete and insert instance commands 2.0.1: ctext_test.tcl removed extra ctext test window 2.0-a6: instance cget -linemap works added more documentation to Readme.txt 2.0-a5: removed hardcoded comment highlighting removed debug output and console show 2.0-a4: > 50% speedup during ctext::highlight due to a simpler regexp that uses not ([^ chars]+) instead. 2.0-a3: fixed bug with cut instance command added fastdelete and fastinsert instance commands instance config -linemap and -yscrollcommand work added highlight instance command added copy, cut, paste, and append selection instance commands 2.0-a2: proc ctext::addHighlightClassForSpecialChars proc ctext::addHighlightClassWithOnlyCharStart highlight function works merged delete from 1.1.1 and fixed a bug insert bug fix tcltk2/inst/tklibs/ctext3.2/install.tcl0000755000176000001440000000330312215417550017502 0ustar ripleyusers#Run this with the wish (Tk shell) that you want to install for. #For example: $ wish8.4 install.tcl proc event.select.install.path win { set i [$win curselection] set ::installPath [$win get $i] } proc install {} { set idir [file join $::installPath ctext] file mkdir $idir file copy -force pkgIndex.tcl $idir file copy -force ctext.tcl $idir tk_messageBox -icon info -message "Successfully installed into $idir" \ -title {Install Successful} -type ok exit } proc main {} { option add *foreground black option add *background gray65 . config -bg gray65 wm title . {Ctext Installer} label .title -text {Welcome to the Ctext installer} -font {Helvetica 14} message .msgauto -aspect 300 -text {The auto_path directories are automatically searched by Tcl/Tk for packages. You may select a directory to install Ctext into, or type in a new directory. Your auto_path directories are:} set autoLen [llength $::auto_path] listbox .listauto -height $autoLen for {set i 0} {$i < $autoLen} {incr i} { .listauto insert end [lindex $::auto_path $i] } bind .listauto <> [list event.select.install.path %W] label .lipath -text {Install Path:} set ::installPath [lindex $::auto_path end] entry .installPath -textvariable ::installPath frame .fcontrol frame .fcontrol.finst -relief sunken -bd 1 pack [button .fcontrol.finst.install -text Install -command install] -padx 4 -pady 4 button .fcontrol.cancel -text Cancel -command exit pack .fcontrol.finst -side left -padx 5 pack .fcontrol.cancel -side right -padx 5 pack .title -fill x pack .msgauto -anchor w pack .listauto -fill both -expand 1 pack .lipath -anchor w pack .installPath -fill x pack .fcontrol -pady 10 } main tcltk2/inst/tklibs/ctext3.2/function_finder.tcl0000755000176000001440000000306312215417550021213 0ustar ripleyusers#!/bin/tclsh8.3 proc main {argc argv} { array set functions "" foreach f $argv { puts stderr "PROCESSING FILE $f" catch {exec cc -DNeedFunctionPrototypes -E $f} data #set functionList [regexp -all -inline {[a-zA-Z0-9_-]+[ \t\n\r]+([a-zA-Z0-9_-]+)[ \t\n\r]+\([ \t\n\r]*([^\)]+)[ \t\n\r]*\)[ \t\n\r]*;} $data] set functionList [regexp -all -inline {[a-zA-Z0-9_\-\*]+[ \t\n\r\*]+([a-zA-Z0-9_\-\*]+)[ \t\n\r]*\(([^\)]*)\)[ \t\n\r]*;} $data] set functionList [concat $functionList \ [regexp -all -inline {[a-zA-Z0-9_\-\*]+[ \t\n\r\*]+([a-zA-Z0-9_\-\*]+)[ \t\n\r]*_ANSI_ARGS_\(\(([^\)]*)\)\)[ \t\n\r]*;} $data]] #puts "FL $functionList" foreach {junk function args} $functionList { #puts "FUNC $function ARGS $args" set args [string map {"\n" "" "\r" "" "\t" " " "," ", "} $args] regsub -all {\s{2,}} $args " " args set functions($function) $args } } puts "array set ::functions \{" foreach function [lsort -dictionary [array names functions]] { if {"_" == [string index $function 0] || "_" == [string index $function end]} { continue } puts "\t$function [list [set functions($function)]]" } puts "\}" } proc sglob {pattern} { return [glob -nocomplain $pattern] } #main $argc /usr/local/include/tclDecls.h #return main $argc [concat [sglob /usr/include/*.h] [sglob /usr/include/*/*.h] \ [sglob /usr/local/include/*.h] [sglob /usr/local/include/*/*.h] \ [sglob /usr/X11R6/include/*.h] [sglob /usr/X11R6/include/*/*.h] \ [sglob /usr/X11R6/include/*/*/*.h] [sglob /usr/local/include/X11/*.h] \ [sglob /usr/local/include/X11/*/*.h]] tcltk2/inst/tklibs/ctext3.2/LICENSE0000644000176000001440000000262112215417550016334 0ustar ripleyusersThis 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. tcltk2/inst/tklibs/ctext3.2/example_interactive.tcl0000755000176000001440000000727412215417550022077 0ustar ripleyusers#!/bin/sh # the next line restarts using wish \ exec wish "$0" ${1+"$@"} #set tcl_traceExec 1 proc linemap_mark_cmd {win type line} { puts "line $line was $type in $win" } proc main {} { source ./ctext.tcl pack [frame .f] -fill both -expand 1 #Of course this could be cscrollbar instead, but it's not as common. pack [scrollbar .f.s -command {.f.t yview}] -side right -fill y #Dark colors pack [ctext .f.t -bg black -fg white -insertbackground yellow \ -yscrollcommand {.f.s set} -linemap_mark_command linemap_mark_cmd] -fill both -expand 1 ctext::addHighlightClass .f.t widgets purple [list obutton button label text frame toplevel \ cscrollbar scrollbar checkbutton canvas listbox menu menubar menubutton \ radiobutton scale entry message tk_chooseDir tk_getSaveFile \ tk_getOpenFile tk_chooseColor tk_optionMenu] ctext::addHighlightClass .f.t flags orange [list -text -command -yscrollcommand \ -xscrollcommand -background -foreground -fg -bg \ -highlightbackground -y -x -highlightcolor -relief -width \ -height -wrap -font -fill -side -outline -style -insertwidth \ -textvariable -activebackground -activeforeground -insertbackground \ -anchor -orient -troughcolor -nonewline -expand -type -message \ -title -offset -in -after -yscroll -xscroll -forward -regexp -count \ -exact -padx -ipadx -filetypes -all -from -to -label -value -variable \ -regexp -backwards -forwards -bd -pady -ipady -state -row -column \ -cursor -highlightcolors -linemap -menu -tearoff -displayof -cursor \ -underline -tags -tag] ctext::addHighlightClass .f.t stackControl red {proc uplevel namespace while for foreach if else} ctext::addHighlightClassWithOnlyCharStart .f.t vars mediumspringgreen "\$" ctext::addHighlightClass .f.t htmlText yellow " " ctext::addHighlightClass .f.t variable_funcs gold {set global variable unset} ctext::addHighlightClassForSpecialChars .f.t brackets green {[]{}} ctext::addHighlightClassForRegexp .f.t paths lightblue {\.[a-zA-Z0-9\_\-]+} ctext::addHighlightClassForRegexp .f.t comments khaki {#[^\n\r]*} #After overloading, insertion is a little slower with the #regular insert, so use fastinsert. #set fi [open Ctext_Bug_Crasher.tcl r] set fi [open long_test_script r] .f.t fastinsert end [read $fi] close $fi pack [frame .f1] -fill x pack [button .f1.append -text Append -command {.f.t append}] -side left pack [button .f1.cut -text Cut -command {.f.t cut}] -side left pack [button .f1.copy -text Copy -command {.f.t copy}] -side left pack [button .f1.paste -text Paste -command {.f.t paste}] -side left .f.t highlight 1.0 end pack [button .f1.test -text {Remove all Tags and Highlight} \ -command {puts [time { foreach tag [.f.t tag names] { .f.t tag remove $tag 1.0 end } update idletasks .f.t highlight 1.0 end }] } ] -side left pack [button .f1.fastdel -text {Fast Delete} -command {.f.t fastdelete 1.0 end}] -side left pack [frame .f2] -fill x pack [button .f2.test2 -text {Scrollbar Command {}} -command {.f.t config -yscrollcommand {}}] -side left pack [button .f2.cl -text {Clear Classes} -command {ctext::clearHighlightClasses .f.t}] -side left pack [button .f2.des -text Destroy -command {destroy .f.t}] -side left pack [button .f2.editModSet0 -text "Set Modified 0" -command {puts [.f.t edit modified 0]}] -side left pack [button .f2.editModGet -text "Print Modified" -command {puts [.f.t edit modified]}] -side left pack [button .f2.exit -text Exit -command exit] -side left pack [entry .e] -side bottom -fill x .e insert end "ctext::deleteHighlightClass .f.t " bind .e {puts [eval [.e get]]} puts [.f.t cget -linemap] puts [.f.t cget -linemapfg] puts [.f.t cget -linemapbg] puts [.f.t cget -bg] } main tcltk2/inst/tklibs/ctext3.2/REGRESSION0000755000176000001440000000034512215417550016736 0ustar ripleyusers Due to changes between the 2.7 and 3.1 release you may need to remove escapes in your class patterns. This is due to my former improper use of quotes, which I have now replaced with lists. The escaping is no longer necessary. tcltk2/inst/tklibs/mclistbox1.2/0000755000176000001440000000000012445051436016203 5ustar ripleyuserstcltk2/inst/tklibs/mclistbox1.2/mclistbox.tcl0000755000176000001440000022451512215417547020733 0ustar ripleyusers# Copyright (c) 1999, Bryan Oakley # All Rights Reservered # # Bryan Oakley # oakley@channelpoint.com # # mclistbox v1.02 March 30, 1999 # # a multicolumn listbox written in pure tcl # # this code is freely distributable without restriction, but is # provided as-is with no waranty expressed or implied. # # basic usage: # # mclistbox::mclistbox .listbox # .listbox column add col1 -label "Column 1" # .listbox column add col2 -label "Column 2" # .listbox insert end [list "some stuff" "some more stuff"] # .listbox insert end [list "a second row of stuff" "blah blah blah"] # # see the documentation for more, uh, documentation. # # Something to think about: implement a "-optimize" option, with two # values: speed and memory. If set to speed, keep a copy of the data # in our hidden listbox so retrieval of data doesn't require us to # do all the getting and splitting and so forth. If set to "memory", # bag saving a duplicate copy of the data, which means data retrieval # will be slower, but memory requirements will be reduced. package require Tk 8.0 package provide mclistbox 1.02 namespace eval ::mclistbox { # this is the public interface namespace export mclistbox # these contain references to available options variable widgetOptions variable columnOptions # these contain references to available commands and subcommands variable widgetCommands variable columnCommands variable labelCommands } # ::mclistbox::Init -- # # Initialize the global (well, namespace) variables. This should # only be called once, immediately prior to creating the first # instance of the widget # # Results: # # All state variables are set to their default values; all of # the option database entries will exist. # # Returns: # # empty string proc ::mclistbox::Init {} { variable widgetOptions variable columnOptions variable widgetCommands variable columnCommands variable labelCommands # here we match up command line options with option database names # and classes. As it turns out, this is a handy reference of all of the # available options. Note that if an item has a value with only one # item (like -bd, for example) it is a synonym and the value is the # actual item. array set widgetOptions [list \ -background {background Background} \ -bd -borderwidth \ -bg -background \ -borderwidth {borderWidth BorderWidth} \ -columnbd -columnborderwidth \ -columnborderwidth {columnBorderWidth BorderWidth} \ -columnrelief {columnRelief Relief} \ -cursor {cursor Cursor} \ -exportselection {exportSelection ExportSelection} \ -fg -foreground \ -fillcolumn {fillColumn FillColumn} \ -font {font Font} \ -foreground {foreground Foreground} \ -height {height Height} \ -highlightbackground {highlightBackground HighlightBackground} \ -highlightcolor {highlightColor HighlightColor} \ -highlightthickness {highlightThickness HighlightThickness} \ -labelanchor {labelAnchor Anchor} \ -labelbackground {labelBackground Background} \ -labelbd -labelborderwidth \ -labelbg -labelbackground \ -labelborderwidth {labelBorderWidth BorderWidth} \ -labelfg -labelforeground \ -labelfont {labelFont Font} \ -labelforeground {labelForeground Foreground} \ -labelheight {labelHeight Height} \ -labelimage {labelImage Image} \ -labelrelief {labelRelief Relief} \ -labels {labels Labels} \ -relief {relief Relief} \ -resizablecolumns {resizableColumns ResizableColumns} \ -selectbackground {selectBackground Foreground} \ -selectborderwidth {selectBorderWidth BorderWidth} \ -selectcommand {selectCommand Command} \ -selectforeground {selectForeground Background} \ -selectmode {selectMode SelectMode} \ -setgrid {setGrid SetGrid} \ -takefocus {takeFocus TakeFocus} \ -width {width Width} \ -xscrollcommand {xScrollCommand ScrollCommand} \ -yscrollcommand {yScrollCommand ScrollCommand} \ ] # and likewise for column-specific stuff. array set columnOptions [list \ -background {background Background} \ -bitmap {bitmap Bitmap} \ -font {font Font} \ -foreground {foreground Foreground} \ -image {image Image} \ -label {label Label} \ -position {position Position} \ -resizable {resizable Resizable} \ -visible {visible Visible} \ -width {width Width} \ ] # this defines the valid widget commands. It's important to # list them here; we use this list to validate commands and # expand abbreviations. set widgetCommands [list \ activate bbox cget column configure \ curselection delete get index insert \ label nearest scan see selection \ size xview yview ] set columnCommands [list add cget configure delete names nearest] set labelCommands [list bind] ###################################################################### #- this initializes the option database. Kinda gross, but it works #- (I think). ###################################################################### set packages [package names] # why check for the Tk package? This lets us be sourced into # an interpreter that doesn't have Tk loaded, such as the slave # interpreter used by pkg_mkIndex. In theory it should have no # side effects when run if {[lsearch -exact [package names] "Tk"] != -1} { # compute a widget name we can use to create a temporary widget set tmpWidget ".__tmp__" set count 0 while {[winfo exists $tmpWidget] == 1} { set tmpWidget ".__tmp__$count" incr count } # steal options from the listbox # we want darn near all options, so we'll go ahead and do # them all. No harm done in adding the one or two that we # don't use. listbox $tmpWidget foreach foo [$tmpWidget configure] { if {[llength $foo] == 5} { set option [lindex $foo 1] set value [lindex $foo 4] option add *Mclistbox.$option $value widgetDefault # these options also apply to the individual columns... if {[string compare $option "foreground"] == 0 \ || [string compare $option "background"] == 0 \ || [string compare $option "font"] == 0} { option add *Mclistbox*MclistboxColumn.$option $value \ widgetDefault } } } destroy $tmpWidget # steal some options from label widgets; we only want a subset # so we'll use a slightly different method. No harm in *not* # adding in the one or two that we don't use... :-) label $tmpWidget foreach option [list Anchor Background Font \ Foreground Height Image ] { set values [$tmpWidget configure -[string tolower $option]] option add *Mclistbox.label$option [lindex $values 3] } destroy $tmpWidget # these are unique to us... option add *Mclistbox.columnBorderWidth 0 widgetDefault option add *Mclistbox.columnRelief flat widgetDefault option add *Mclistbox.labelBorderWidth 1 widgetDefault option add *Mclistbox.labelRelief raised widgetDefault option add *Mclistbox.labels 1 widgetDefault option add *Mclistbox.resizableColumns 1 widgetDefault option add *Mclistbox.selectcommand {} widgetDefault option add *Mclistbox.fillcolumn {} widgetDefault # column options option add *Mclistbox*MclistboxColumn.visible 1 widgetDefault option add *Mclistbox*MclistboxColumn.resizable 1 widgetDefault option add *Mclistbox*MclistboxColumn.position end widgetDefault option add *Mclistbox*MclistboxColumn.label "" widgetDefault option add *Mclistbox*MclistboxColumn.width 0 widgetDefault option add *Mclistbox*MclistboxColumn.bitmap "" widgetDefault option add *Mclistbox*MclistboxColumn.image "" widgetDefault } ###################################################################### # define the class bindings ###################################################################### SetClassBindings } # ::mclistbox::mclistbox -- # # This is the command that gets exported. It creates a new # mclistbox widget. # # Arguments: # # w path of new widget to create # args additional option/value pairs (eg: -background white, etc.) # # Results: # # It creates the widget and sets up all of the default bindings # # Returns: # # The name of the newly create widget proc ::mclistbox::mclistbox {args} { variable widgetOptions # perform a one time initialization if {![info exists widgetOptions]} { Init } # make sure we at least have a widget name if {[llength $args] == 0} { error "wrong # args: should be \"mclistbox pathName ?options?\"" } # ... and make sure a widget doesn't already exist by that name if {[winfo exists [lindex $args 0]]} { error "window name \"[lindex $args 0]\" already exists" } # and check that all of the args are valid foreach {name value} [lrange $args 1 end] { Canonize [lindex $args 0] option $name } # build it... set w [eval Build $args] # set some bindings... SetBindings $w # and we are done! return $w } # ::mclistbox::Build -- # # This does all of the work necessary to create the basic # mclistbox. # # Arguments: # # w widget name # args additional option/value pairs # # Results: # # Creates a new widget with the given name. Also creates a new # namespace patterened after the widget name, as a child namespace # to ::mclistbox # # Returns: # # the name of the widget proc ::mclistbox::Build {w args} { variable widgetOptions # create the namespace for this instance, and define a few # variables namespace eval ::mclistbox::$w { variable options variable widgets variable misc } # this gives us access to the namespace variables within # this proc upvar ::mclistbox::${w}::widgets widgets upvar ::mclistbox::${w}::options options upvar ::mclistbox::${w}::misc misc # initially we start out with no columns set misc(columns) {} # this is our widget -- a frame of class Mclistbox. Naturally, # it will contain other widgets. We create it here because # we need it to be able to set our default options. set widgets(this) [frame $w -class Mclistbox -takefocus 1] # this defines all of the default options. We get the # values from the option database. Note that if an array # value is a list of length one it is an alias to another # option, so we just ignore it foreach name [array names widgetOptions] { if {[llength $widgetOptions($name)] == 1} continue set optName [lindex $widgetOptions($name) 0] set optClass [lindex $widgetOptions($name) 1] set options($name) [option get $w $optName $optClass] } # now apply any of the options supplied on the command # line. This may overwrite our defaults, which is OK if {[llength $args] > 0} { array set options $args } # the columns all go into a text widget since it has the # ability to scroll. set widgets(text) [text $w.text \ -width 0 \ -height 0 \ -padx 0 \ -pady 0 \ -wrap none \ -borderwidth 0 \ -highlightthickness 0 \ -takefocus 0 \ -cursor {} \ ] $widgets(text) configure -state disabled # here's the tricky part (shhhh... don't tell anybody!) # we are going to create column that completely fills # the base frame. We will use it to control the sizing # of the widget. The trick is, we'll pack it in the frame # and then place the text widget over it so it is never # seen. set columnWidgets [NewColumn $w {__hidden__}] set widgets(hiddenFrame) [lindex $columnWidgets 0] set widgets(hiddenListbox) [lindex $columnWidgets 1] set widgets(hiddenLabel) [lindex $columnWidgets 2] # by default geometry propagation is turned off, but for this # super-secret widget we want it turned on. The idea is, we # resize the listbox which resizes the frame which resizes the # whole shibang. pack propagate $widgets(hiddenFrame) on pack $widgets(hiddenFrame) -side top -fill both -expand y place $widgets(text) -x 0 -y 0 -relwidth 1.0 -relheight 1.0 raise $widgets(text) # we will later rename the frame's widget proc to be our # own custom widget proc. We need to keep track of this # new name, so we'll define and store it here... set widgets(frame) ::mclistbox::${w}::$w # this moves the original frame widget proc into our # namespace and gives it a handy name rename ::$w $widgets(frame) # now, create our widget proc. Obviously (?) it goes in # the global namespace. All mclistbox widgets will actually # share the same widget proc to cut down on the amount of # bloat. proc ::$w {command args} \ "eval ::mclistbox::WidgetProc {$w} \$command \$args" # ok, the thing exists... let's do a bit more configuration. if {[catch "Configure $widgets(this) [array get options]" error]} { catch {destroy $w} } # and be prepared to handle selections.. (this, for -exportselection # support) selection handle $w [list ::mclistbox::SelectionHandler $w get] return $w } # ::mclistbox::SelectionHandler -- # # handle reqests to set or retrieve the primary selection. This is # the "guts" of the implementation of the -exportselection option. # What a pain! Note that this command is *not* called as a result # of the widget's "selection" command, but rather as a result of # the global selection being set or cleared. # # If I read the ICCCM correctly (which is doubtful; who has time to # read that thing thoroughly?), this should return each row as a tab # separated list of values, and the whole as a newline separated # list of rows. # # Arguments: # # w pathname of the widget # type one of "own", "lose" or "get" # offset only used if type is "get"; offset into the selection # buffer where the returned data should begin # length number of bytes to return # proc ::mclistbox::SelectionHandler {w type {offset ""} {length ""}} { upvar ::mclistbox::${w}::options options upvar ::mclistbox::${w}::misc misc upvar ::mclistbox::${w}::widgets widgets switch -exact $type { own { selection own \ -command [list ::mclistbox::SelectionHandler $w lose] \ -selection PRIMARY \ $w } lose { if {$options(-exportselection)} { foreach id $misc(columns) { $widgets(listbox$id) selection clear 0 end } } } get { set end [expr {$length + $offset - 1}] set column [lindex $misc(columns) 0] set curselection [$widgets(listbox$column) curselection] # this is really, really slow (relatively speaking). # but the only way I can think of to speed this up # is to duplicate all the data in our hidden listbox, # which I really don't want to do because of memory # considerations. set data "" foreach index $curselection { set rowdata [join [::mclistbox::WidgetProc-get $w $index] "\t"] lappend data $rowdata } set data [join $data "\n"] return [string range $data $offset $end] } } } # ::mclistbox::convert -- # # public routine to convert %x, %y and %W binding substitutions. # Given an x, y and or %W value relative to a given widget, this # routine will convert the values to be relative to the mclistbox # widget. For example, it could be used in a binding like this: # # bind .mclistbox {doSomething [::mclistbox::convert %W -x %x]} # # Note that this procedure is *not* exported, but is indented for # public use. It is not exported because the name could easily # clash with existing commands. # # Arguments: # # w a widget path; typically the actual result of a %W # substitution in a binding. It should be either a # mclistbox widget or one of its subwidgets # # args should one or more of the following arguments or # pairs of arguments: # # -x will convert the value ; typically will # be the result of a %x substitution # -y will convert the value ; typically will # be the result of a %y substitution # -W (or -w) will return the name of the mclistbox widget # which is the parent of $w # # Returns: # # a list of the requested values. For example, a single -w will # result in a list of one items, the name of the mclistbox widget. # Supplying "-x 10 -y 20 -W" (in any order) will return a list of # three values: the converted x and y values, and the name of # the mclistbox widget. proc ::mclistbox::convert {w args} { set result {} if {![winfo exists $w]} { error "window \"$w\" doesn't exist" } while {[llength $args] > 0} { set option [lindex $args 0] set args [lrange $args 1 end] switch -exact -- $option { -x { set value [lindex $args 0] set args [lrange $args 1 end] set win $w while {[winfo class $win] != "Mclistbox"} { incr value [winfo x $win] set win [winfo parent $win] if {$win == "."} break } lappend result $value } -y { set value [lindex $args 0] set args [lrange $args 1 end] set win $w while {[winfo class $win] != "Mclistbox"} { incr value [winfo y $win] set win [winfo parent $win] if {$win == "."} break } lappend result $value } -w - -W { set win $w while {[winfo class $win] != "Mclistbox"} { set win [winfo parent $win] if {$win == "."} break; } lappend result $win } } } return $result } # ::mclistbox::SetBindings -- # # Sets up the default bindings for the named widget # # Arguments: # # w the widget pathname for which the bindings should be assigned # # Results: # # The named widget will inheirit all of the default Mclistbox # bindings. proc ::mclistbox::SetBindings {w} { upvar ::mclistbox::${w}::widgets widgets upvar ::mclistbox::${w}::options options upvar ::mclistbox::${w}::misc misc # we must do this so that the columns fill the text widget in # the y direction bind $widgets(text) \ [list ::mclistbox::AdjustColumns $w %h] } # ::mclistbox::SetClassBindings -- # # Sets up the default bindings for the widget class # # Arguments: # # none # proc ::mclistbox::SetClassBindings {} { # this allows us to clean up some things when we go away bind Mclistbox [list ::mclistbox::DestroyHandler %W] # steal all of the standard listbox bindings. Note that if a user # clicks in a column, %W will return that column. This is bad, # so we have to make a substitution in all of the bindings to # compute the real widget name (ie: the name of the topmost # frame) foreach event [bind Listbox] { set binding [bind Listbox $event] regsub -all {%W} $binding {[::mclistbox::convert %W -W]} binding regsub -all {%x} $binding {[::mclistbox::convert %W -x %x]} binding regsub -all {%y} $binding {[::mclistbox::convert %W -y %y]} binding bind Mclistbox $event $binding } # these define bindings for the column labels for resizing. Note # that we need both the name of this widget (calculated by $this) # as well as the specific widget that the event occured over. # Also note that $this is a constant string that gets evaluated # when the binding fires. # What a pain. set this {[::mclistbox::convert %W -W]} bind MclistboxMouseBindings \ "::mclistbox::ResizeEvent $this buttonpress %W %x %X %Y" bind MclistboxMouseBindings \ "::mclistbox::ResizeEvent $this buttonrelease %W %x %X %Y" bind MclistboxMouseBindings \ "::mclistbox::ResizeEvent $this motion %W %x %X %Y" bind MclistboxMouseBindings \ "::mclistbox::ResizeEvent $this motion %W %x %X %Y" bind MclistboxMouseBindings \ "::mclistbox::ResizeEvent $this drag %W %x %X %Y" } # ::mclistbox::NewColumn -- # # Adds a new column to the mclistbox widget # # Arguments: # # w the widget pathname # id the id for the new column # # Results: # # Creates a set of widgets which defines the column. Adds # appropriate entries to the global array widgets for the # new column. # # Note that this column is not added to the listbox by # this proc. # # Returns: # # A list of three elements: the path to the column frame, # the path to the column listbox, and the path to the column # label, in that order. proc ::mclistbox::NewColumn {w id} { upvar ::mclistbox::${w}::widgets widgets upvar ::mclistbox::${w}::options options upvar ::mclistbox::${w}::misc misc upvar ::mclistbox::${w}::columnID columnID # the columns are all children of the text widget we created... set frame \ [frame $w.frame$id \ -takefocus 0 \ -highlightthickness 0 \ -class MclistboxColumn \ -background $options(-background) \ ] set listbox \ [listbox $frame.listbox \ -takefocus 0 \ -bd 0 \ -setgrid $options(-setgrid) \ -exportselection false \ -selectmode $options(-selectmode) \ -highlightthickness 0 \ ] set label \ [label $frame.label \ -takefocus 0 \ -relief raised \ -bd 1 \ -highlightthickness 0 \ ] # define mappings from widgets to columns set columnID($label) $id set columnID($frame) $id set columnID($listbox) $id # we're going to associate a new bindtag for the label to # handle our resize bindings. Why? We want the bindings to # be specific to this widget but we don't want to use the # widget name. If we use the widget name then the bindings # could get mixed up with user-supplied bindigs (via the # "label bind" command). set tag MclistboxLabel bindtags $label [list MclistboxMouseBindings $label] # reconfigure the label based on global options foreach option [list bd image height relief font anchor \ background foreground borderwidth] { if {[info exists options(-label$option)] \ && $options(-label$option) != ""} { $label configure -$option $options(-label$option) } } # reconfigure the column based on global options foreach option [list borderwidth relief] { if {[info exists options(-column$option)] \ && $options(-column$option) != ""} { $frame configure -$option $options(-column$option) } } # geometry propagation must be off so we can control the size # of the listbox by setting the size of the containing frame pack propagate $frame off pack $label -side top -fill x -expand n pack $listbox -side top -fill both -expand y -pady 2 # any events that happen in the listbox gets handled by the class # bindings. This has the unfortunate side effect bindtags $listbox [list $w Mclistbox all] # return a list of the widgets we created. return [list $frame $listbox $label] } # ::mclistbox::Column-add -- # # Implements the "column add" widget command # # Arguments: # # w the widget pathname # args additional option/value pairs which define the column # # Results: # # A column gets created and added to the listbox proc ::mclistbox::Column-add {w args} { upvar ::mclistbox::${w}::widgets widgets upvar ::mclistbox::${w}::options options upvar ::mclistbox::${w}::misc misc variable widgetOptions set id "column-[llength $misc(columns)]" ;# a suitable default # if the first argument doesn't have a "-" as the first # character, it is an id to associate with this column if {![string match {-*} [lindex $args 0]]} { # the first arg must be an id. set id [lindex $args 0] set args [lrange $args 1 end] if {[lsearch -exact $misc(columns) $id] != -1} { error "column \"$id\" already exists" } } # define some reasonable defaults, then add any specific # values supplied by the user set opts(-bitmap) {} set opts(-image) {} set opts(-visible) 1 set opts(-resizable) 1 set opts(-position) "end" set opts(-width) 20 set opts(-background) $options(-background) set opts(-foreground) $options(-foreground) set opts(-font) $options(-font) set opts(-label) $id if {[expr {[llength $args]%2}] == 1} { # hmmm. An odd number of elements in args # if the last item is a valid option we'll give a different # error than if its not set option [::mclistbox::Canonize $w "column option" [lindex $args end]] error "value for \"[lindex $args end]\" missing" } array set opts $args # figure out if we have any data in the listbox yet; we'll need # this information in a minute... if {[llength $misc(columns)] > 0} { set col0 [lindex $misc(columns) 0] set existingRows [$widgets(listbox$col0) size] } else { set existingRows 0 } # create the widget and assign the associated paths to our array set widgetlist [NewColumn $w $id] set widgets(frame$id) [lindex $widgetlist 0] set widgets(listbox$id) [lindex $widgetlist 1] set widgets(label$id) [lindex $widgetlist 2] # add this column to the list of known columns lappend misc(columns) $id # configure the options. As a side effect, it will be inserted # in the text widget eval ::mclistbox::Column-configure {$w} {$id} [array get opts] # now, if there is any data already in the listbox, we need to # add a corresponding number of blank items. At least, I *think* # that's the right thing to do. if {$existingRows > 0} { set blanks {} for {set i 0} {$i < $existingRows} {incr i} { lappend blanks {} } eval {$widgets(listbox$id)} insert end $blanks } InvalidateScrollbars $w return $id } # ::mclistbox::Column-configure -- # # Implements the "column configure" widget command # # Arguments: # # w widget pathname # id column identifier # args list of option/value pairs proc ::mclistbox::Column-configure {w id args} { variable widgetOptions variable columnOptions upvar ::mclistbox::${w}::widgets widgets upvar ::mclistbox::${w}::options options upvar ::mclistbox::${w}::misc misc # bail if they gave us a bogus id set index [CheckColumnID $w $id] # define some shorthand set listbox $widgets(listbox$id) set frame $widgets(frame$id) set label $widgets(label$id) if {[llength $args] == 0} { # hmmm. User must be wanting all configuration information # note that if the value of an array element is of length # one it is an alias, which needs to be handled slightly # differently set results {} foreach opt [lsort [array names columnOptions]] { if {[llength $columnOptions($opt)] == 1} { set alias $columnOptions($opt) set optName $columnOptions($alias) lappend results [list $opt $optName] } else { set optName [lindex $columnOptions($opt) 0] set optClass [lindex $columnOptions($opt) 1] set default [option get $frame $optName $optClass] lappend results [list $opt $optName $optClass \ $default $options($id:$opt)] } } return $results } elseif {[llength $args] == 1} { # the user must be querying something... I need to get this # to return a bona fide list like the "real" configure # command, but it's not a priority at the moment. I still # have to work on the option database support foo. set option [::mclistbox::Canonize $w "column option" [lindex $args 0]] set value $options($id:$option) set optName [lindex $columnOptions($option) 0] set optClass [lindex $columnOptions($option) 1] set default [option get $frame $optName $optClass] set results [list $option $optName $optClass $default $value] return $results } # if we have an odd number of values, bail. if {[expr {[llength $args]%2}] == 1} { # hmmm. An odd number of elements in args error "value for \"[lindex $args end]\" missing" } # Great. An even number of options. Let's make sure they # are all valid before we do anything. Note that Canonize # will generate an error if it finds a bogus option; otherwise # it returns the canonical option name foreach {name value} $args { set name [::mclistbox::Canonize $w "column option" $name] set opts($name) $value } # if we get to here, the user is wanting to set some options foreach option [array names opts] { set value $opts($option) set options($id:$option) $value switch -- $option { -label { $label configure -text $value } -image - -bitmap { $label configure $option $value } -width { set font [$listbox cget -font] set factor [font measure $options(-font) "0"] set width [expr {$value * $factor}] $widgets(frame$id) configure -width $width set misc(min-$widgets(frame$id)) $width AdjustColumns $w } -font - -foreground - -background { if {[string length $value] == 0} {set value $options($option)} $listbox configure $option $value } -resizable { if {[catch { if {$value} { set options($id:-resizable) 1 } else { set options($id:-resizable) 0 } } msg]} { error "expected boolean but got \"$value\"" } } -visible { if {[catch { if {$value} { set options($id:-visible) 1 $widgets(text) configure -state normal $widgets(text) window configure 1.$index -window $frame $widgets(text) configure -state disabled } else { set options($id:-visible) 0 $widgets(text) configure -state normal $widgets(text) window configure 1.$index -window {} $widgets(text) configure -state disabled } InvalidateScrollbars $w } msg]} { error "expected boolean but got \"$value\"" } } -position { if {[string compare $value "start"] == 0} { set position 0 } elseif {[string compare $value "end"] == 0} { set position [expr {[llength $misc(columns)] -1}] } else { # ought to check for a legal value here, but I'm # lazy set position $value } if {$position >= [llength $misc(columns)]} { set max [expr {[llength $misc(columns)] -1}] error "bad position; must be in the range of 0-$max" } # rearrange misc(columns) to reflect the new ordering set current [lsearch -exact $misc(columns) $id] set misc(columns) [lreplace $misc(columns) $current $current] set misc(columns) [linsert $misc(columns) $position $id] set frame $widgets(frame$id) $widgets(text) configure -state normal $widgets(text) window create 1.$position \ -window $frame -stretch 1 $widgets(text) configure -state disabled } } } } # ::mclistbox::DestroyHandler {w} -- # # Cleans up after a mclistbox widget is destroyed # # Arguments: # # w widget pathname # # Results: # # The namespace that was created for the widget is deleted, # and the widget proc is removed. proc ::mclistbox::DestroyHandler {w} { # kill off any idle event we might have pending if {[info exists ::mclistbox::${w}::misc(afterid)]} { catch { after cancel $::mclistbox::${w}::misc(afterid) unset ::mclistbox::${w}::misc(afterid) } } # if the widget actually being destroyed is of class Mclistbox, # crush the namespace and kill the proc. Get it? Crush. Kill. # Destroy. Heh. Danger Will Robinson! Oh, man! I'm so funny it # brings tears to my eyes. if {[string compare [winfo class $w] "Mclistbox"] == 0} { namespace delete ::mclistbox::$w rename $w {} } } # ::mclistbox::MassageIndex -- # # this proc massages indicies of the form @x,y such that # the coordinates are relative to the first listbox rather # than relative to the topmost frame. # # Arguments: # # w widget pathname # index an index of the form @x,y # # Results: # # Returns a new index with translated coordinates. This index # may be used directly by an internal listbox. proc ::mclistbox::MassageIndex {w index} { upvar ::mclistbox::${w}::widgets widgets upvar ::mclistbox::${w}::misc misc if {[regexp {@([0-9]+),([0-9]+)} $index matchvar x y]} { set id [lindex $misc(columns) 0] incr y -[winfo y $widgets(listbox$id)] incr y -[winfo y $widgets(frame$id)] incr x [winfo x $widgets(listbox$id)] incr x [winfo x $widgets(frame$id)] set index @${x},${y} } return $index } # ::mclistbox::WidgetProc -- # # This gets uses as the widgetproc for an mclistbox widget. # Notice where the widget is created and you'll see that the # actual widget proc merely evals this proc with all of the # arguments intact. # # Note that some widget commands are defined "inline" (ie: # within this proc), and some do most of their work in # separate procs. This is merely because sometimes it was # easier to do it one way or the other. # # Arguments: # # w widget pathname # command widget subcommand # args additional arguments; varies with the subcommand # # Results: # # Performs the requested widget command proc ::mclistbox::WidgetProc {w command args} { variable widgetOptions upvar ::mclistbox::${w}::widgets widgets upvar ::mclistbox::${w}::options options upvar ::mclistbox::${w}::misc misc upvar ::mclistbox::${w}::columnID columnID set command [::mclistbox::Canonize $w command $command] # some commands have subcommands. We'll check for that here # and mung the command and args so that we can treat them as # distinct commands in the following switch statement if {[string compare $command "column"] == 0} { set subcommand [::mclistbox::Canonize $w "column command" \ [lindex $args 0]] set command "$command-$subcommand" set args [lrange $args 1 end] } elseif {[string compare $command "label"] == 0} { set subcommand [::mclistbox::Canonize $w "label command" \ [lindex $args 0]] set command "$command-$subcommand" set args [lrange $args 1 end] } set result "" catch {unset priorSelection} # here we go. Error checking be damned! switch $command { xview { # note that at present, "xview " is broken. I'm # not even sure how to do it. Unless I attach our hidden # listbox to the scrollbar and use it. Hmmm..... I'll # try that later. (FIXME) set result [eval {$widgets(text)} xview $args] InvalidateScrollbars $w } yview { if {[llength $args] == 0} { # length of zero means to fetch the yview; we can # get this from a single listbox set result [$widgets(hiddenListbox) yview] } else { # if it's one argument, it's an index. We'll pass that # index through the index command to properly translate # @x,y indicies, and place the value back in args if {[llength $args] == 1} { set index [::mclistbox::MassageIndex $w [lindex $args 0]] set args [list $index] } # run the yview command on every column. foreach id $misc(columns) { eval {$widgets(listbox$id)} yview $args } eval {$widgets(hiddenListbox)} yview $args InvalidateScrollbars $w set result "" } } activate { if {[llength $args] != 1} { error "wrong \# of args: should be $w activate index" } set index [::mclistbox::MassageIndex $w [lindex $args 0]] foreach id $misc(columns) { $widgets(listbox$id) activate $index } set result "" } bbox { if {[llength $args] != 1} { error "wrong \# of args: should be $w bbox index" } # get a real index. This will adjust @x,y indicies # to account for the label, if any. set index [::mclistbox::MassageIndex $w [lindex $args 0]] set id [lindex $misc(columns) 0] # we can get the x, y, and height from the first # column. set bbox [$widgets(listbox$id) bbox $index] if {[string length $bbox] == 0} {return ""} foreach {x y w h} $bbox {} # the x and y coordinates have to be adjusted for the # fact that the listbox is inside a frame, and the # frame is inside a text widget. All of those add tiny # offsets. Feh. incr y [winfo y $widgets(listbox$id)] incr y [winfo y $widgets(frame$id)] incr x [winfo x $widgets(listbox$id)] incr x [winfo x $widgets(frame$id)] # we can get the width by looking at the relative x # coordinate of the right edge of the last column set id [lindex $misc(columns) end] set w [expr {[winfo width $widgets(frame$id)] + \ [winfo x $widgets(frame$id)]}] set bbox [list $x $y [expr {$x + $w}] $h] set result $bbox } label-bind { # we are just too clever for our own good. (that's a # polite way of saying this is more complex than it # needs to be) set id [lindex $args 0] set index [CheckColumnID $w $id] set args [lrange $args 1 end] if {[llength $args] == 0} { set result [bind $widgets(label$id)] } else { # when we create a binding, we'll actually have the # binding run our own command with the user's command # as an argument. This way we can do some sanity checks # before running the command. So, when querying a binding # we need to only return the user's code set sequence [lindex $args 0] if {[llength $args] == 1} { set result [lindex [bind $widgets(label$id) $sequence] end] } else { # replace %W with our toplevel frame, then # do the binding set code [lindex $args 1] regsub -all {%W} $code $w code set result [bind $widgets(label$id) $sequence \ [list ::mclistbox::LabelEvent $w $id $code]] } } } column-add { eval ::mclistbox::Column-add {$w} $args AdjustColumns $w set result "" } column-delete { foreach id $args { set index [CheckColumnID $w $id] # remove the reference from our list of columns set misc(columns) [lreplace $misc(columns) $index $index] # whack the widget destroy $widgets(frame$id) # clear out references to the individual widgets unset widgets(frame$id) unset widgets(listbox$id) unset widgets(label$id) } InvalidateScrollbars $w set result "" } column-cget { if {[llength $args] != 2} { error "wrong # of args: should be \"$w column cget name option\"" } set id [::mclistbox::Canonize $w column [lindex $args 0]] set option [lindex $args 1] set data [::mclistbox::Column-configure $w $id $option] set result [lindex $data 4] } column-configure { set id [::mclistbox::Canonize $w column [lindex $args 0]] set args [lrange $args 1 end] set result [eval ::mclistbox::Column-configure {$w} {$id} $args] } column-names { if {[llength $args] != 0} { error "wrong # of args: should be \"$w column names\"" } set result $misc(columns) } column-nearest { if {[llength $args] != 1} { error "wrong # of args: should be \"$w column nearest x\"" } set x [lindex $args 0] set tmp [$widgets(text) index @$x,0] set tmp [split $tmp "."] set index [lindex $tmp 1] set result [lindex $misc(columns) $index] } cget { if {[llength $args] != 1} { error "wrong # args: should be $w cget option" } set opt [::mclistbox::Canonize $w option [lindex $args 0]] set result $options($opt) } configure { set result [eval ::mclistbox::Configure {$w} $args] } curselection { set id [lindex $misc(columns) 0] set result [$widgets(listbox$id) curselection] } delete { if {[llength $args] < 1 || [llength $args] > 2} { error "wrong \# of args: should be $w delete first ?last?" } # it's possible that the selection will change because # of something we do. So, grab the current selection before # we do anything. Just before returning we'll see if the # selection has changed. If so, we'll call our selectcommand if {$options(-selectcommand) != ""} { set col0 [lindex $misc(columns) 0] set priorSelection [$widgets(listbox$col0) curselection] } set index1 [::mclistbox::MassageIndex $w [lindex $args 0]] if {[llength $args] == 2} { set index2 [::mclistbox::MassageIndex $w [lindex $args 1]] } else { set index2 "" } # note we do an eval here to make index2 "disappear" if it # is set to an empty string. foreach id $misc(columns) { eval {$widgets(listbox$id)} delete $index1 $index2 } eval {$widgets(hiddenListbox)} delete $index1 $index2 InvalidateScrollbars $w set result "" } get { if {[llength $args] < 1 || [llength $args] > 2} { error "wrong \# of args: should be $w get first ?last?" } set index1 [::mclistbox::MassageIndex $w [lindex $args 0]] if {[llength $args] == 2} { set index2 [::mclistbox::MassageIndex $w [lindex $args 1]] } else { set index2 "" } set result [eval ::mclistbox::WidgetProc-get {$w} $index1 $index2] } index { if {[llength $args] != 1} { error "wrong \# of args: should be $w index index" } set index [::mclistbox::MassageIndex $w [lindex $args 0]] set id [lindex $misc(columns) 0] set result [$widgets(listbox$id) index $index] } insert { if {[llength $args] < 1} { error "wrong \# of args: should be $w insert ?element \ element...?" } # it's possible that the selection will change because # of something we do. So, grab the current selection before # we do anything. Just before returning we'll see if the # selection has changed. If so, we'll call our selectcommand if {$options(-selectcommand) != ""} { set col0 [lindex $misc(columns) 0] set priorSelection [$widgets(listbox$col0) curselection] } set index [::mclistbox::MassageIndex $w [lindex $args 0]] ::mclistbox::Insert $w $index [lrange $args 1 end] InvalidateScrollbars $w set result "" } nearest { if {[llength $args] != 1} { error "wrong \# of args: should be $w nearest y" } # translate the y coordinate into listbox space set id [lindex $misc(columns) 0] set y [lindex $args 0] incr y -[winfo y $widgets(listbox$id)] incr y -[winfo y $widgets(frame$id)] set col0 [lindex $misc(columns) 0] set result [$widgets(listbox$col0) nearest $y] } scan { foreach {subcommand x y} $args {} switch $subcommand { mark { # we have to treat scrolling in x and y differently; # scrolling in the y direction affects listboxes and # scrolling in the x direction affects the text widget. # to facilitate that, we need to keep a local copy # of the scan mark. set misc(scanmarkx) $x set misc(scanmarky) $y # set the scan mark for each column foreach id $misc(columns) { $widgets(listbox$id) scan mark $x $y } # we can't use the x coordinate given us, since it # is relative to whatever column we are over. So, # we'll just usr the results of [winfo pointerx]. $widgets(text) scan mark [winfo pointerx $w] $y } dragto { # we want the columns to only scan in the y direction, # so we'll force the x componant to remain constant foreach id $misc(columns) { $widgets(listbox$id) scan dragto $misc(scanmarkx) $y } # since the scan mark of the text widget was based # on the pointer location, so must be the x # coordinate to the dragto command. And since we # want the text widget to only scan in the x # direction, the y componant will remain constant $widgets(text) scan dragto \ [winfo pointerx $w] $misc(scanmarky) # make sure the scrollbars reflect the changes. InvalidateScrollbars $w } set result "" } } see { if {[llength $args] != 1} { error "wrong \# of args: should be $w see index" } set index [::mclistbox::MassageIndex $w [lindex $args 0]] foreach id $misc(columns) { $widgets(listbox$id) see $index } InvalidateScrollbars $w set result {} } selection { # it's possible that the selection will change because # of something we do. So, grab the current selection before # we do anything. Just before returning we'll see if the # selection has changed. If so, we'll call our selectcommand if {$options(-selectcommand) != ""} { set col0 [lindex $misc(columns) 0] set priorSelection [$widgets(listbox$col0) curselection] } set subcommand [lindex $args 0] set args [lrange $args 1 end] set prefix "wrong \# of args: should be $w" switch $subcommand { includes { if {[llength $args] != 1} { error "$prefix selection $subcommand index" } set index [::mclistbox::MassageIndex $w [lindex $args 0]] set id [lindex $misc(columns) 0] set result [$widgets(listbox$id) selection includes $index] } set { switch [llength $args] { 1 { set index1 [::mclistbox::MassageIndex $w \ [lindex $args 0]] set index2 "" } 2 { set index1 [::mclistbox::MassageIndex $w \ [lindex $args 0]] set index2 [::mclistbox::MassageIndex $w \ [lindex $args 1]] } default { error "$prefix selection clear first ?last?" } } if {$options(-exportselection)} { SelectionHandler $w own } if {$index1 != ""} { foreach id $misc(columns) { eval {$widgets(listbox$id)} selection set \ $index1 $index2 } } set result "" } anchor { if {[llength $args] != 1} { error "$prefix selection $subcommand index" } set index [::mclistbox::MassageIndex $w [lindex $args 0]] if {$options(-exportselection)} { SelectionHandler $w own } foreach id $misc(columns) { $widgets(listbox$id) selection anchor $index } set result "" } clear { switch [llength $args] { 1 { set index1 [::mclistbox::MassageIndex $w \ [lindex $args 0]] set index2 "" } 2 { set index1 [::mclistbox::MassageIndex $w \ [lindex $args 0]] set index2 [::mclistbox::MassageIndex $w \ [lindex $args 1]] } default { error "$prefix selection clear first ?last?" } } if {$options(-exportselection)} { SelectionHandler $w own } foreach id $misc(columns) { eval {$widgets(listbox$id)} selection clear \ $index1 $index2 } set result "" } } } size { set id [lindex $misc(columns) 0] set result [$widgets(listbox$id) size] } } # if the user has a selectcommand defined and the selection changed, # run the selectcommand if {[info exists priorSelection] && $options(-selectcommand) != ""} { set column [lindex $misc(columns) 0] set currentSelection [$widgets(listbox$column) curselection] if {[string compare $priorSelection $currentSelection] != 0} { # this logic keeps us from getting into some sort of # infinite loop of the selectcommand changes the selection # (not particularly well tested, but it seems like the # right thing to do...) if {![info exists misc(skipRecursiveCall)]} { set misc(skipRecursiveCall) 1 uplevel \#0 $options(-selectcommand) $currentSelection catch {unset misc(skipRecursiveCall)} } } } return $result } # ::mclistbox::WidgetProc-get -- # # Implements the "get" widget command # # Arguments: # # w widget path # args additional arguments to the get command proc ::mclistbox::WidgetProc-get {w args} { upvar ::mclistbox::${w}::widgets widgets upvar ::mclistbox::${w}::options options upvar ::mclistbox::${w}::misc misc set returnType "list" # the listbox "get" command returns different things # depending on whether it has one or two args. Internally # we *always* want a valid list, so we'll force a second # arg which in turn forces the listbox to return a list, # even if its a list of one element if {[llength $args] == 1} { lappend args [lindex $args 0] set returnType "listOfLists" } # get all the data from each column foreach id $misc(columns) { set data($id) [eval {$widgets(listbox$id)} get $args] } # now join the data together one row at a time. Ugh. set result {} set rows [llength $data($id)] for {set i 0} {$i < $rows} {incr i} { set this {} foreach column $misc(columns) { lappend this [lindex $data($column) $i] } lappend result $this } # now to unroll the list if necessary. If the user gave # us only one indicie we want to return a single list # of values. If they gave use two indicies we want to return # a list of lists. if {[string compare $returnType "list"] == 0} { return $result } else { return [lindex $result 0] } } # ::mclistbox::CheckColumnID -- # # returns the index of the id within our list of columns, or # reports an error if the id is invalid # # Arguments: # # w widget pathname # id a column id # # Results: # # Will compute and return the index of the column within the # list of columns (which happens to be it's -position, as it # turns out) or returns an error if the named column doesn't # exist. proc ::mclistbox::CheckColumnID {w id} { upvar ::mclistbox::${w}::misc misc set id [::mclistbox::Canonize $w column $id] set index [lsearch -exact $misc(columns) $id] return $index } # ::mclistbox::LabelEvent -- # # Handle user events on the column labels for the Mclistbox # class. # # Arguments: # # w widget pathname # id a column identifier # code tcl code to be evaluated. # # Results: # # Executes the code associate with an event, but only if the # event wouldn't otherwise potentially trigger a resize event. # # We use the cursor of the label to let us know whether the # code should be executed. If it is set to the cursor of the # mclistbox widget, the code will be executed. It is assumed # that if it is not the same cursor, it is the resize cursor # which should only be set if the cursor is very near a border # of a label and the column is resizable. proc ::mclistbox::LabelEvent {w id code} { upvar ::mclistbox::${w}::widgets widgets upvar ::mclistbox::${w}::options options # only fire the binding if the cursor is our default cursor # (ie: if we aren't in a "resize zone") set cursor [$widgets(label$id) cget -cursor] if {[string compare $cursor $options(-cursor)] == 0} { uplevel \#0 $code } } # ::mclistbox::HumanizeList -- # # Returns a human-readable form of a list by separating items # by columns, but separating the last two elements with "or" # (eg: foo, bar or baz) # # Arguments: # # list a valid tcl list # # Results: # # A string which as all of the elements joined with ", " or # the word " or " proc ::mclistbox::HumanizeList {list} { if {[llength $list] == 1} { return [lindex $list 0] } else { set list [lsort $list] set secondToLast [expr {[llength $list] -2}] set most [lrange $list 0 $secondToLast] set last [lindex $list end] return "[join $most {, }] or $last" } } # ::mclistbox::Canonize -- # # takes a (possibly abbreviated) option or command name and either # returns the canonical name or an error # # Arguments: # # w widget pathname # object type of object to canonize; must be one of "command", # "option", "column" or "column option". # opt the option (or command) to be canonized # # Returns: # # Returns either the canonical form of an option or command, # or raises an error if the option or command is unknown or # ambiguous. proc ::mclistbox::Canonize {w object opt} { variable widgetOptions variable columnOptions variable widgetCommands variable columnCommands variable labelCommands switch $object { command { if {[lsearch -exact $widgetCommands $opt] >= 0} { return $opt } # command names aren't stored in an array, and there # isn't a way to get all the matches in a list, so # we'll stuff the columns in a temporary array so # we can use [array names] set list $widgetCommands foreach element $list { set tmp($element) "" } set matches [array names tmp ${opt}*] } {label command} { if {[lsearch -exact $labelCommands $opt] >= 0} { return $opt } # command names aren't stored in an array, and there # isn't a way to get all the matches in a list, so # we'll stuff the columns in a temporary array so # we can use [array names] set list $labelCommands foreach element $list { set tmp($element) "" } set matches [array names tmp ${opt}*] } {column command} { if {[lsearch -exact $columnCommands $opt] >= 0} { return $opt } # command names aren't stored in an array, and there # isn't a way to get all the matches in a list, so # we'll stuff the columns in a temporary array so # we can use [array names] set list $columnCommands foreach element $list { set tmp($element) "" } set matches [array names tmp ${opt}*] } option { if {[info exists widgetOptions($opt)] \ && [llength $widgetOptions($opt)] == 3} { return $opt } set list [array names widgetOptions] set matches [array names widgetOptions ${opt}*] } {column option} { if {[info exists columnOptions($opt)]} { return $opt } set list [array names columnOptions] set matches [array names columnOptions ${opt}*] } column { upvar ::mclistbox::${w}::misc misc if {[lsearch -exact $misc(columns) $opt] != -1} { return $opt } # column names aren't stored in an array, and there # isn't a way to get all the matches in a list, so # we'll stuff the columns in a temporary array so # we can use [array names] set list $misc(columns) foreach element $misc(columns) { set tmp($element) "" } set matches [array names tmp ${opt}*] } } if {[llength $matches] == 0} { set choices [HumanizeList $list] error "unknown $object \"$opt\"; must be one of $choices" } elseif {[llength $matches] == 1} { # deal with option aliases set opt [lindex $matches 0] switch $object { option { if {[llength $widgetOptions($opt)] == 1} { set opt $widgetOptions($opt) } } {column option} { if {[llength $columnOptions($opt)] == 1} { set opt $columnOptions($opt) } } } return $opt } else { set choices [HumanizeList $list] error "ambiguous $object \"$opt\"; must be one of $choices" } } # ::mclistbox::Configure -- # # Implements the "configure" widget subcommand # # Arguments: # # w widget pathname # args zero or more option/value pairs (or a single option) # # Results: # # Performs typcial "configure" type requests on the widget proc ::mclistbox::Configure {w args} { variable widgetOptions upvar ::mclistbox::${w}::widgets widgets upvar ::mclistbox::${w}::options options upvar ::mclistbox::${w}::misc misc if {[llength $args] == 0} { # hmmm. User must be wanting all configuration information # note that if the value of an array element is of length # one it is an alias, which needs to be handled slightly # differently set results {} foreach opt [lsort [array names widgetOptions]] { if {[llength $widgetOptions($opt)] == 1} { set alias $widgetOptions($opt) set optName $widgetOptions($alias) lappend results [list $opt $optName] } else { set optName [lindex $widgetOptions($opt) 0] set optClass [lindex $widgetOptions($opt) 1] set default [option get $w $optName $optClass] lappend results [list $opt $optName $optClass \ $default $options($opt)] } } return $results } # one argument means we are looking for configuration # information on a single option if {[llength $args] == 1} { set opt [::mclistbox::Canonize $w option [lindex $args 0]] set optName [lindex $widgetOptions($opt) 0] set optClass [lindex $widgetOptions($opt) 1] set default [option get $w $optName $optClass] set results [list $opt $optName $optClass \ $default $options($opt)] return $results } # if we have an odd number of values, bail. if {[expr {[llength $args]%2}] == 1} { # hmmm. An odd number of elements in args error "value for \"[lindex $args end]\" missing" } # Great. An even number of options. Let's make sure they # are all valid before we do anything. Note that Canonize # will generate an error if it finds a bogus option; otherwise # it returns the canonical option name foreach {name value} $args { set name [::mclistbox::Canonize $w option $name] set opts($name) $value } # process all of the configuration options foreach option [array names opts] { set newValue $opts($option) if {[info exists options($option)]} { set oldValue $options($option) # set options($option) $newValue } switch -- $option { -exportselection { if {$newValue} { SelectionHandler $w own set options($option) 1 } else { set options($option) 0 } } -fillcolumn { # if the fill column changed, we need to adjust # the columns. AdjustColumns $w set options($option) $newValue } -takefocus { $widgets(frame) configure -takefocus $newValue set options($option) [$widgets(frame) cget $option] } -background { foreach id $misc(columns) { $widgets(listbox$id) configure -background $newValue $widgets(frame$id) configure -background $newValue } $widgets(frame) configure -background $newValue $widgets(text) configure -background $newValue set options($option) [$widgets(frame) cget $option] } # { the following all must be applied to each listbox } -foreground - -font - -selectborderwidth - -selectforeground - -selectbackground - -setgrid { foreach id $misc(columns) { $widgets(listbox$id) configure $option $newValue } $widgets(hiddenListbox) configure $option $newValue set options($option) [$widgets(hiddenListbox) cget $option] } # { the following all must be applied to each listbox and frame } -cursor { foreach id $misc(columns) { $widgets(listbox$id) configure $option $newValue $widgets(frame$id) configure -cursor $newValue } # -cursor also needs to be applied to the # frames of each column foreach id $misc(columns) { $widgets(frame$id) configure -cursor $newValue } $widgets(hiddenListbox) configure $option $newValue set options($option) [$widgets(hiddenListbox) cget $option] } # { this just requires to pack or unpack the labels } -labels { if {$newValue} { set newValue 1 foreach id $misc(columns) { pack $widgets(label$id) \ -side top -fill x -expand n \ -before $widgets(listbox$id) } pack $widgets(hiddenLabel) \ -side top -fill x -expand n \ -before $widgets(hiddenListbox) } else { set newValue foreach id $misc(columns) { pack forget $widgets(label$id) } pack forget $widgets(hiddenLabel) } set options($option) $newValue } -height { $widgets(hiddenListbox) configure -height $newValue InvalidateScrollbars $w set options($option) [$widgets(hiddenListbox) cget $option] } -width { if {$newValue == 0} { error "a -width of zero is not supported. " } $widgets(hiddenListbox) configure -width $newValue InvalidateScrollbars $w set options($option) [$widgets(hiddenListbox) cget $option] } # { the following all must be applied to each column frame } -columnborderwidth - -columnrelief { regsub {column} $option {} listboxoption foreach id $misc(columns) { $widgets(listbox$id) configure $listboxoption $newValue } $widgets(hiddenListbox) configure $listboxoption $newValue set options($option) [$widgets(hiddenListbox) cget \ $listboxoption] } -resizablecolumns { if {$newValue} { set options($option) 1 } else { set options($option) 0 } } # { the following all must be applied to each column header } -labelimage - -labelheight - -labelrelief - -labelfont - -labelanchor - -labelbackground - -labelforeground - -labelborderwidth { regsub {label} $option {} labeloption foreach id $misc(columns) { $widgets(label$id) configure $labeloption $newValue } $widgets(hiddenLabel) configure $labeloption $newValue set options($option) [$widgets(hiddenLabel) cget $labeloption] } # { the following apply only to the topmost frame} -borderwidth - -highlightthickness - -highlightcolor - -highlightbackground - -relief { $widgets(frame) configure $option $newValue set options($option) [$widgets(frame) cget $option] } -selectmode { set options($option) $newValue } -selectcommand { set options($option) $newValue } -xscrollcommand { InvalidateScrollbars $w set options($option) $newValue } -yscrollcommand { InvalidateScrollbars $w set options($option) $newValue } } } } # ::mclistbox::UpdateScrollbars -- # # This proc does the work of actually update the scrollbars to # reflect the current view # # Arguments: # # w widget pathname # # Results: # # Potentially changes the size or placement of the scrollbars # (if any) based on changes to the widget proc ::mclistbox::UpdateScrollbars {w} { upvar ::mclistbox::${w}::widgets widgets upvar ::mclistbox::${w}::options options upvar ::mclistbox::${w}::misc misc if {![winfo ismapped $w]} { catch {unset misc(afterid)} return } update idletasks if {[llength $misc(columns)] > 0} { if {[string length $options(-yscrollcommand)] != 0} { set col0 [lindex $misc(columns) 0] set yview [$widgets(listbox$col0) yview] eval $options(-yscrollcommand) $yview } if {[string length $options(-xscrollcommand)] != 0} { set col0 [lindex $misc(columns) 0] set xview [$widgets(text) xview] eval $options(-xscrollcommand) $xview } } catch {unset misc(afterid)} } # ::mclistbox::InvalidateScrollbars -- # # Schedules the scrollbars to be updated the next time # we are idle. # # Arguments: # # w widget pathname # # Results: # # sets up a proc to be run in the idle event handler proc ::mclistbox::InvalidateScrollbars {w} { upvar ::mclistbox::${w}::widgets widgets upvar ::mclistbox::${w}::options options upvar ::mclistbox::${w}::misc misc if {![info exists misc(afterid)]} { set misc(afterid) \ [after idle "catch {::mclistbox::UpdateScrollbars $w}"] } } # ::mclistbox::Insert -- # # This implements the "insert" widget command; it arranges for # one or more elements to be inserted into the listbox. # # Arguments: # # w widget pathname # index a valid listbox index to designate where the data is # to be inserted # arglist A list of values to be inserted. Each element of the # list will itself be treated as a list, one element for # each column. # # Results: # # Inserts the data into the list and updates the scrollbars proc ::mclistbox::Insert {w index arglist} { upvar ::mclistbox::${w}::widgets widgets upvar ::mclistbox::${w}::options options upvar ::mclistbox::${w}::misc misc foreach list $arglist { # make sure we have enough elements for each column for {set i [llength $list]} {$i < [llength $misc(columns)]} {incr i} { lappend list {} } set column 0 foreach id $misc(columns) { $widgets(listbox$id) insert $index [lindex $list $column] incr column } # we also want to add a bogus item to the hidden listbox. Why? # For standard listboxes, if you specify a height of zero the # listbox will resize to be just big enough to hold all the lines. # Since we use a hidden listbox to regulate the size of the widget # and we want this same behavior, this listbox needs the same number # of elements as the visible listboxes # # (NB: we might want to make this listbox contain the contents # of all columns as a properly formatted list; then the get # command can query this listbox instead of having to query # each individual listbox. The disadvantage is that it doubles # the memory required to hold all the data) $widgets(hiddenListbox) insert $index "x" } return "" } # ::mclistbox::ColumnIsHidden -- # # Returns a boolean representing whether a column is visible or # not # # Arguments: # # w widget pathname # id a column identifier # # Results: # # returns 1 if the column is visible (ie: not hidden), or 0 # if invisible. Note that the result doesn't consider whether # the column is actually viewable. Even if it has been scrolled # off screen, 1 will be returned as long as the column hasn't # been hidden by turning the visibility off. proc ::mclistbox::ColumnIsHidden {w id} { upvar ::mclistbox::${w}::widgets widgets upvar ::mclistbox::${w}::misc misc set retval 1 set col [lsearch -exact $misc(columns) $id] if {$col != ""} { set index "1.$col" catch { set window [$widgets(text) window cget $index -window] if {[string length $window] > 0 && [winfo exists $window]} { set retval 0 } } } return $retval } # ::mclistbox::AdjustColumns -- # # Adjusts the height and width of the individual columns. # # Arguments: # # w widget pathname # height height, in pixels, that the columns should be adjusted # to. If null, the height will be the height of the text # widget that underlies our columns. # # Results: # # All columns will be adjusted to fill the text widget in the y # direction. Also, if a -fillcolumn is defined, that column will # be grown, if necessary, to fill the widget in the x direction. proc ::mclistbox::AdjustColumns {w {height ""}} { upvar ::mclistbox::${w}::widgets widgets upvar ::mclistbox::${w}::options options upvar ::mclistbox::${w}::misc misc if {[string length $height] == 0} { set height [winfo height $widgets(text)] } # resize the height of each column so it matches the height # of the text widget, minus a few pixels. incr height -4 foreach id $misc(columns) { $widgets(frame$id) configure -height $height } # if we have a fillcolumn, change its width accordingly if {$options(-fillcolumn) != ""} { # make sure the column has been defined. If not, bail (?) if {![info exists widgets(frame$options(-fillcolumn))]} { return } set frame $widgets(frame$options(-fillcolumn)) set minwidth $misc(min-$frame) # compute current width of all columns set colwidth 0 set col 0 foreach id $misc(columns) { if {![ColumnIsHidden $w $id] && $id != $options(-fillcolumn)} { incr colwidth [winfo reqwidth $widgets(frame$id)] } } # this is just shorthand for later use... set id $options(-fillcolumn) # compute optimal width set optwidth [expr {[winfo width $widgets(text)] - \ (2 * [$widgets(text) cget -padx])}] # compute the width of our fill column set newwidth [expr {$optwidth - $colwidth}] if {$newwidth < $minwidth} { set newwidth $minwidth } # adjust the width of our fill column frame $widgets(frame$id) configure -width $newwidth } InvalidateScrollbars $w } # ::mclistbox::FindResizableNeighbor -- # # Returns the nearest resizable column to the left or right # of the named column. # # Arguments: # # w widget pathname # id column identifier # direction should be one of "right" or "left". Actually, anything # that doesn't match "right" will be treated as "left" # # Results: # # Will return the column identifier of the nearest resizable # column, or an empty string if none exists. proc ::mclistbox::FindResizableNeighbor {w id {direction right}} { upvar ::mclistbox::${w}::widgets widgets upvar ::mclistbox::${w}::options options upvar ::mclistbox::${w}::misc misc if {$direction == "right"} { set incr 1 set stop [llength $misc(columns)] set start [expr {[lsearch -exact $misc(columns) $id] + 1}] } else { set incr -1 set stop -1 set start [expr {[lsearch -exact $misc(columns) $id] - 1}] } for {set i $start} {$i != $stop} {incr i $incr} { set col [lindex $misc(columns) $i] if {![ColumnIsHidden $w $col] && $options($col:-resizable)} { return $col } } return "" } # ::mclistbox::ResizeEvent -- # # Handles the events which implement interactive column resizing # using the mouse. # # Arguments: # # w widget pathname # type type of event; must be one of "buttonpress", "drag", # "motion", or "buttonrelease" # widget the actual widget that the event occured over # x the x coordinate of the mouse, relative to $widget # X the root x coordinate of the mouse # Y the root y coordinate of the mouse # # The basic idea is this: # # whenever the cursor moves over the label, we examine it's x # coordinate to determine if its within a fixed amount of # pixels from the left or right edge. If it is, we reconfigure # the cursor to be a suitable "this thing is resizable" cursor. # # On a buttonclick, if the cursor is not the default cursor # (and thus, presumably the resize cursor), we set up some # state for an eventual resize. We figure out which columns # are to the left and right and base a maximum resize amount # for each direction. We also define the absolute X coordinate # of the buttonpress as a reference point for the drag. # # on a b1-motion, if the drag state exists, we look at the # absolute X value and use it to compute a delta value from # the reference (the X of the button press). We then resize the # left and right column frames by the delta amount. # # on a button release, we unset the state and the cursor, which # cancels all of the above. proc ::mclistbox::ResizeEvent {w type widget x X Y} { upvar ::mclistbox::${w}::widgets widgets upvar ::mclistbox::${w}::options options upvar ::mclistbox::${w}::misc misc upvar ::mclistbox::${w}::columnID columnID # if the widget doesn't allow resizable cursors, there's # nothing here to do... if {!$options(-resizablecolumns)} { return } # this lets us keep track of some internal state while # the user is dragging the mouse variable drag # this lets us define a small window around the edges of # the column. set threshold [expr {$options(-labelborderwidth) + 4}] # this is what we use for the "this is resizable" cursor set resizeCursor sb_h_double_arrow # if we aren't over an area that we care about, bail. if {![info exists columnID($widget)]} { return } # id refers to the column name set id $columnID($widget) switch $type { buttonpress { # we will do all the work of initiating a drag only if # the cursor is not the defined cursor. In theory this # will only be the case if the mouse moves over the area # in which a drag can happen. if {[$widgets(label$id) cget -cursor] == $resizeCursor} { if {$x <= $threshold} { set lid [::mclistbox::FindResizableNeighbor $w $id left] if {$lid == ""} return set drag(leftFrame) $widgets(frame$lid) set drag(rightFrame) $widgets(frame$id) set drag(leftListbox) $widgets(listbox$lid) set drag(rightListbox) $widgets(listbox$id) } else { set rid [::mclistbox::FindResizableNeighbor $w $id right] if {$rid == ""} return set drag(leftFrame) $widgets(frame$id) set drag(rightFrame) $widgets(frame$rid) set drag(leftListbox) $widgets(listbox$id) set drag(rightListbox) $widgets(listbox$rid) } set drag(leftWidth) [winfo width $drag(leftFrame)] set drag(rightWidth) [winfo width $drag(rightFrame)] # it seems to be a fact that windows can never be # less than one pixel wide. So subtract that one pixel # from our max deltas... set drag(maxDelta) [expr {$drag(rightWidth) - 1}] set drag(minDelta) -[expr {$drag(leftWidth) - 1}] set drag(x) $X } } motion { if {[info exists drag(x)]} {return} # this is just waaaaay too much work for a motion # event, IMO. set resizable 0 # is the column the user is over resizable? if {!$options($id:-resizable)} {return} # did the user click on the left of a column? if {$x < $threshold} { set leftColumn [::mclistbox::FindResizableNeighbor $w $id left] if {$leftColumn != ""} { set resizable 1 } } elseif {$x > [winfo width $widget] - $threshold} { set rightColumn [::mclistbox::FindResizableNeighbor $w $id \ right] if {$rightColumn != ""} { set resizable 1 } } # if it's resizable, change the cursor set cursor [$widgets(label$id) cget -cursor] if {$resizable && $cursor != $resizeCursor} { $widgets(label$id) configure -cursor $resizeCursor } elseif {!$resizable && $cursor == $resizeCursor} { $widgets(label$id) configure -cursor $options(-cursor) } } drag { # if the state is set up, do the drag... if {[info exists drag(x)]} { set delta [expr {$X - $drag(x)}] if {$delta >= $drag(maxDelta)} { set delta $drag(maxDelta) } elseif {$delta <= $drag(minDelta)} { set delta $drag(minDelta) } set lwidth [expr {$drag(leftWidth) + $delta}] set rwidth [expr {$drag(rightWidth) - $delta}] $drag(leftFrame) configure -width $lwidth $drag(rightFrame) configure -width $rwidth } } buttonrelease { set fillColumnID $options(-fillcolumn) if {[info exists drag(x)] && $fillColumnID != {}} { set fillColumnFrame $widgets(frame$fillColumnID) if {[string compare $drag(leftFrame) $fillColumnFrame] == 0 \ || [string compare $drag(rightFrame) $fillColumnFrame] == 0} { set width [$fillColumnFrame cget -width] set misc(minFillColumnSize) $width } set misc(min-$drag(leftFrame)) [$drag(leftFrame) cget -width] set misc(min-$drag(rightFrame)) [$drag(rightFrame) cget -width] } # reset the state and the cursor catch {unset drag} $widgets(label$id) configure -cursor $options(-cursor) } } } # end of mclistbox.tcl tcltk2/inst/tklibs/mclistbox1.2/mclistbox.pod0000755000176000001440000003370012215417547020725 0ustar ripleyusers# mclistbox.pod # Copyright (c) 1999, Bryan Oakley # All Rights Reserved. # # this uses a modified version of pod2html. Specifically, it uses the # non-standard R<> directive, which inserts a line break. =pod =head2 NAME mclistbox::mclistbox - Create and manipulate a multi-column listbox =head2 SYNOPSIS B B I I =head2 EXPORTS mclistbox =head2 STANDARD OPTIONS B<-background> B<-borderwidth> B<-cursor> B<-exportselection> B<-font> B<-foreground> B<-height> B<-highlightbackground> B<-highlightcolor> B<-highlightthickness> B<-relief> B<-selectbackground> B<-selectborderwidth> B<-selectforeground> B<-setgrid> B<-takefocus> B<-width> B<-xscrollcommand> B<-yscrollcommand> See the I manual entry for detailed descriptions of the above options. =head2 WIDGET-SPECIFIC OPTIONS Command-Line Name: B<-columnborderwidth> R<> Database Name: BR<> Database Class: B Specifies a non-negative value indicating the width of the 3-D border to draw around the outside of the column (if such a border is being drawn; the B option typically determines this). The value may also be used when drawing 3-D effects in the interior of the widget. The value may have any of the forms acceptable to Tk_GetPixels. Command-Line Name: B<-columnrelief> R<> Database Name: B R<> Database Class: B Specifies the 3-D effect desired for the column. Acceptable values are raised, B, B, B, B, and B. The value indicates how the interior of the column should appear relative to its exterior; for example, raised means the interior of the column should appear to protrude from the screen, relative to the exterior of the column. Command-Line Name: B<-fillcolumn> R<> Database Name: BR<> Database Class: B Specifies which column should grow or shrink such that all columns exactly fill the listbox widget. Command-Line Name: B<-labelanchor> R<> Database Name: BR<> Database Class: B Specifies how the information in the column label is to be displayed. Must be one of the values B, B, B, B, B, B, B, B, or B

. For example, nw means display the information such that its top-left corner is at the top-left corner of the column label. Command-Line Name: B<-labelbackground> or B<-labelbg>R<> Database Name: B R<> Database Class: B Specifies the normal background color to use when displaying the label. Command-Line Name: B<-labelborderwidth or -labelbd> R<> Database Name: B R<> Database Class: B Specifies a non-negative value indicating the width of the 3-D border to draw around the outside of the column label (if such a border is being drawn; the relief option typically determines this). The value may also be used when drawing 3-D effects in the interior of the column label. The value may have any of the forms acceptable to Tk_GetPixels. Command-Line Name: B<-labelfont> R<> Database Name: B R<> Database Class: B Specifies the font to use when drawing text inside the column label. Command-Line Name: B<-labelforeground> R<> Database Name: B R<> Database Class: B Specifies the normal foreground color to use when displaying the column label. Command-Line Name: B<-labelheight> R<> Database Name: BR<> Database Class: B Specifies a desired height for the label. If an image or bitmap is being displayed in the label then the value is in screen units (i.e. any of the forms acceptable to Tk_GetPixels); for text it is in lines of text. If this option isn't specified, the label's desired height is computed from the size of the image or bitmap or text being displayed in it. Command-Line Name: B<-labelrelief> R<> Database Name: BR<> Database Class: B Specifies the 3-D effect desired for the column label. Acceptable values are B, B, B, B, B, and B. The value indicates how the interior of the column label should appear relative to its exterior; for example, raised means the interior of the column label should appear to protrude from the screen, relative to the exterior of the column label. Command-Line Name: B<-labels> R<> Database Name: BR<> Database Class: B A boolean value which determines whether column labels are shown or not. Command-Line Name: B<-selectcommand> I R<> Database Name: BR<> Database Class: B Specifies a Tcl command to be run whenever the selection in the mclistbox changes. The command will be called with the result of the curselection command. Command-Line Name: B<-resizablecolumns> R<> Database Name: B R<> Database Class: B Specifies whether the columns can be resized interactively. If set to true, mouse bindings will be defined to allow the columns to be resized. See B for more information. Command-Line Name: B<-selectmode> R<> Database Name: BR<> Database Class: B Specifies one of several styles for manipulating the selection. The value of the option may be arbitrary, but the default bindings expect it to be either B, B, B, or B; the default value is browse. =head2 DESCRIPTION The B command creates a new window (given by the I argument) and makes it into a mclistbox widget. Additional options, described above, may be specified on the command line to configure aspects of the mclistbox such as its colors, font, text, and relief. The mclistbox command returns its pathName argument. At the time this command is invoked, there must not exist a window named pathName, but pathName's parent must exist. A mclistbox is a widget that displays a list of strings, one per line. When first created, a new mclistbox has no elements and no columns. Columns and elementd may be added or deleted using widget commands described below. In addition, one or more elements may be selected as described below. When an element in one column is selected, the elements in all columns are selected. It is not necessary for all the elements to be displayed in the mclistbox window at once; commands described below may be used to change the view in the window. Mclistboxes allow scrolling in both directions using the standard xScrollCommand and yScrollCommand options. They also support scanning, as described below. =head2 WIDGET COMMAND The widget command accepts many of the same arguments as the standard listbox command. The following commands behave identically to the standard listbox commands: =over 4 B B B B B B B B B B B B B B =back In addition, there are a few commands unique to the mclistbox: =over 4 =item I B I