"====================================================================== | | Smalltalk Tk-based GUI building blocks (basic widget classes). | | $Revision: 1.7.5$ | $Date: 2000/05/28 16:56:52$ | $Author: pb$ | ======================================================================" "====================================================================== | | Copyright 1988-92, 1994-95, 1999, 2000 Free Software Foundation, Inc. | Written by Paolo Bonzini. | | This file is part of the GNU Smalltalk class library. | | The GNU Smalltalk class library is free software; you can redistribute it | and/or modify it under the terms of the GNU Lesser General Public License | as published by the Free Software Foundation; either version 2.1, or (at | your option) any later version. | | The GNU Smalltalk class library is distributed in the hope that it will be | useful, but WITHOUT ANY WARRANTY; without even the implied warranty of | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser | General Public License for more details. | | You should have received a copy of the GNU Lesser General Public License | along with the GNU Smalltalk class library; see the file COPYING.LESSER. | If not, write to the Free Software Foundation, 59 Temple Place - Suite | 330, Boston, MA 02111-1307, USA. | ======================================================================" "-------------------------- Edit boxes ---------------------------" BPrimitive subclass: #BEdit instanceVariableNames: 'callback' classVariableNames: 'Initialized' poolDictionaries: '' category: 'Graphics-Windows' ! BEdit comment: ' I am a control showing one line of modifiable text.'! BEdit defineFontProtocol; defineColorProtocolWithActivePrefix: 'select' tk: 'select'! !BEdit class methodsFor: 'private'! initializeOnStartup Initialized := false ! ! !BEdit class methodsFor: 'instance creation'! new: parent contents: aString "Answer a new BEdit widget laid inside the given parent widget, with a default content of aString" ^(self new: parent) contents: aString; yourself ! ! !BEdit methodsFor: 'accessing'! callback ^callback ! callback: aReceiver message: aString callback := DirectedMessage selector: aString asSymbol arguments: #() receiver: aReceiver ! contents self tclEval: 'return ${var', self connected, '}'. ^self tclResult ! contents: newText self tclEval: 'set var', self connected, ' ', newText asTkString ! ! !BEdit methodsFor: 'widget protocol'! destroyed self tclEval: 'unset var', self connected. super destroyed. ! hasSelection self tclEval: self connected, ' selection present'. ^self tclResult = '1' ! insertText: aString self tclEval: 'catch { %1 delete sel.first sel.last } %1 insert insert %2 %1 see insert' with: self connected with: aString asTkString ! nextPut: aCharacter self insertAtEnd: (String with: aCharacter) ! nextPutAll: aString self insertAtEnd: aString ! nl self insertAtEnd: Character nl asString ! invokeCallback self callback isNil ifFalse: [ self callback send ] ! insertAtEnd: aString self tclEval: '%1 selection clear %1 insert end %2 %1 see end' with: self connected with: aString asTkString ! replaceSelection: aString self tclEval: 'catch { %1 icursor sel.first %1 delete sel.first sel.last } %1 insert insert %2 %1 select insert [expr %3 + [%1 index insert]] %1 see insert' with: self connected with: aString asTkString with: aString size printString ! selection | stream first | self tclEval: 'if [%1 selection present] { return [string range ${var%1} [%1 index sel.first] [%1 index sel.last]]" }' with: self connected. ^self tclResult ! selectionRange | stream first | self tclEval: 'if [%1 selection present] { return "[%1 index sel.first] [%1 index sel.last]" }' with: self connected. stream := ReadStream on: self tclResult. stream atEnd ifTrue: [ ^nil ]. first := (stream upTo: $ ) asInteger + 1. ^first to: stream upToEnd asInteger + 1 ! selectAll self tclEval: self connected, ' selection range 0 end' ! selectFrom: first to: last self tclEval: '%1 selection range %2 %3' with: self connected with: (first - 1) printString with: (last - 1) printString ! space self insertAtEnd: ' ' ! ! !BEdit methodsFor: 'private'! create super create. Initialized ifFalse: [ self defineCallbackProcedure ]. self tclEval: ' set var%1 {} bind %1 <> {callback %2 invokeCallback} trace variable var%1 w doEditCallback %1 configure -textvariable var%1 -highlightthickness 0 -takefocus 1' with: self connected with: self asOop printString. ! defineCallbackProcedure Initialized := true. self tclEval: ' proc doEditCallback { name el op } { regsub ^var $name {} widgetName event generate $widgetName <> }' ! setInitialSize "Make the Tk placer's status, the receiver's properties and the window status (as returned by winfo) consistent. Occupy the height indicated by the widget itself and the whole of the parent's width, at the top left corner" self x: 0 y: 0; width: self parent width. ! widgetType ^'entry' ! ! "---------------------------- Labels -----------------------------" BPrimitive subclass: #BLabel instanceVariableNames: '' classVariableNames: 'AnchorPoints' poolDictionaries: '' category: 'Graphics-Windows' ! BLabel comment: ' I am a label showing static text.'! BLabel defineFontProtocol; defineColorProtocol; defineAccessor: 'label' option: 'text' fromStringCode: ''; defineMutator: 'label' option: 'text' toStringCode: ''; defineMutator: 'anchor' option: 'anchor' toStringCode: ''! !BLabel class methodsFor: 'initialization'! initialize (AnchorPoints := IdentityDictionary new: 15) at: #topLeft put: 'nw'; at: #topCenter put: 'n'; at: #topRight put: 'ne'; at: #leftCenter put: 'w'; at: #center put: 'center'; at: #rightCenter put: 'e'; at: #bottomLeft put: 'sw'; at: #bottomCenter put: 's'; at: #bottomRight put: 'se' ! ! !BLabel class methodsFor: 'instance creation'! new: parent label: label "Answer a new BLabel widget laid inside the given parent widget, showing by default the `label' String." ^(self new: parent) label: label; yourself ! ! !BLabel methodsFor: 'accessing'! alignment ^self properties at: #alignment ifAbsent: [ #topLeft ] ! alignment: aSymbol self anchor: (AnchorPoints at: aSymbol). self properties at: #alignment put: aSymbol. ! ! !BLabel methodsFor: 'private'! create self create: '-anchor nw -takefocus 0'. self tclEval: 'bind %1 "+%1 configure -wraplength %%w"' with: self connected ! initialize: parentWidget super initialize: parentWidget. parentWidget isNil ifFalse: [ self backgroundColor: parentWidget backgroundColor ]. ! setInitialSize "Make the Tk placer's status, the receiver's properties and the window status (as returned by winfo) consistent. Occupy the area indicated by the widget itself, at the top left corner" self x: 0 y: 0. ! widgetType ^'label' ! ! BLabel initialize! "---------------------------- Buttons ----------------------------" BPrimitive subclass: #BButton instanceVariableNames: 'callback' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BButton comment: ' I am a button that a user can click. In fact I am at the head of a small hierarchy of objects which exhibit button-like look and behavior'! BButton defineFontProtocol; defineColorProtocol; defineAccessor: 'label' option: 'text' fromStringCode: ''; defineMutator: 'label' option: 'text' toStringCode: ''! !BButton class methodsFor: 'instance creation'! new: parent label: label "Answer a new BButton widget laid inside the given parent widget, showing by default the `label' String." ^(self new: parent) label: label; yourself ! ! !BButton methodsFor: 'accessing'! callback ^callback ! callback: aReceiver message: aString callback := DirectedMessage selector: aString asSymbol arguments: #() receiver: aReceiver ! invokeCallback self callback isNil ifFalse: [ self callback send ] ! ! !BButton methodsFor: 'private'! create self create: ('-highlightthickness 0 -takefocus 1 -command {callback %1 invokeCallback}' bindWith: self asOop printString) ! setInitialSize "Make the Tk placer's status, the receiver's properties and the window status (as returned by winfo) consistent. Occupy the area indicated by the widget itself, at the top left corner" self x: 0 y: 0. ! widgetType ^'button' ! ! "---------------------------- Forms ------------------------------" BPrimitive subclass: #BForm instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BForm comment: ' I am used to group many controls together. I leave the heavy task of managing their position to the user.'! BForm defineAccessor: 'defaultHeight' option: 'height' fromStringCode: 'asNumber'; defineAccessor: 'defaultWidth' option: 'width' fromStringCode: 'asNumber'; defineMutator: 'defaultHeight' option: 'height' toStringCode: 'printString'; defineMutator: 'defaultWidth' option: 'width' toStringCode: 'printString'; defineAccessor: 'backgroundColor' option: 'background' fromStringCode: ''; defineMutator: 'backgroundColor' option: 'background' toStringCode: ''! !BForm methodsFor: 'private'! create self create: '-highlightthickness 0 -takefocus 0 -width 1 -height 1' ! initialize: parentWidget super initialize: parentWidget. parentWidget isNil ifFalse: [ self backgroundColor: parentWidget backgroundColor ]. ! widgetType ^'frame' ! ! "---------------------------- Containers -------------------------" BForm subclass: #BContainer instanceVariableNames: 'vertical' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BContainer comment: ' I am used to group many controls together. I can perform simple management by putting controls next to each other, from left to right or from top to bottom.'! !BContainer methodsFor: 'accessing'! setVerticalLayout: aBoolean children isEmpty ifFalse: [ ^self error: 'cannot set layout after the first child is created' ]. vertical := aBoolean. ! ! !BContainer methodsFor: 'flexibility'! position: child below: last child posVert: last ! position: child toTheRightOf: last child posHoriz: last ! ! !BContainer methodsFor: 'private'! addChild: child | last | vertical isNil ifTrue: [ self setVerticalLayout: true ]. last := children isEmpty ifTrue: [ nil ] ifFalse: [ children at: children size ]. super addChild: child. last isNil ifFalse: [ vertical ifTrue: [ self position: child below: last ] ifFalse: [ self position: child toTheRightOf: last ] ]. ^child ! ! "------------------------------ Radio Groups ------------------------------" BContainer subclass: #BRadioGroup instanceVariableNames: 'lastValue lastAssignedValue' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BRadioGroup comment: ' I am used to group many mutually-exclusive radio buttons together. In addition, just like every BContainer I can perform simple management by putting controls next to each other, from left to right or (which is more useful in this particular case...) from top to bottom.'! !BRadioGroup methodsFor: 'accessing'! value self tclEval: 'return ${var', self connected, '}'. ^self tclResult asInteger ! value: value self tclEval: 'set var', self connected, ' ', value printString ! ! !BRadioGroup methodsFor: 'widget protocol'! destroyed self tclEval: 'unset var', self connected. super destroyed. ! ! !BRadioGroup methodsFor: 'private'! initialize: parentWidget super initialize: parentWidget. lastAssignedValue := lastValue := 0. self tclEval: 'set ', self variable, ' 1'. ! lastValue ^lastValue ! lastValue: value lastValue := value ! newButtonValue ^lastAssignedValue := lastAssignedValue + 1 ! variable ^'var', self connected ! ! "------------------------------ Radio buttons ------------------------------" BButton subclass: #BRadioButton instanceVariableNames: 'variableValue' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BRadioButton comment: ' I am just one in a group of mutually exclusive buttons.'! BRadioButton defineMutator: 'variableValue' option: 'value' toStringCode: 'printString'; defineMutator: 'variable' option: 'variable' toStringCode: ''! !BRadioButton methodsFor: 'accessing'! callback: aReceiver message: aString super callback: aReceiver message: aString. self callback arguments: (Array with: true) ! value ^self parent value = variableValue ! value: aBoolean aBoolean ifTrue: [ self parent value: variableValue ]. "aBoolean is false - unhighlight everything if we're active" self value ifTrue: [ self parent value: 0 ] ! ! !BRadioButton methodsFor: 'private'! initialize: parentWidget super initialize: parentWidget. variableValue := self parent newButtonValue. self tclEval: self connected, ' configure -anchor nw'; variableValue: variableValue; variable: self parent variable; backgroundColor: parentWidget backgroundColor. variableValue = 1 ifTrue: [self parent value: 1] ! widgetType ^'radiobutton' ! ! "------------------------------ Toggles ------------------------------------" BButton subclass: #BToggle instanceVariableNames: 'value variableReturn' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BToggle comment: ' I represent a button whose choice can be included (by checking me) or excluded (by leaving me unchecked).'! BToggle defineMutator: 'variable' option: 'variable' toStringCode: ''! !BToggle methodsFor: 'accessing'! callback: aReceiver message: aString super callback: aReceiver message: aString. self callback arguments: (Array with: nil) ! invokeCallback self callback isNil ifTrue: [ ^self ]. self callback arguments at: 1 put: self value. super invokeCallback ! value self tclEval: 'return ${var', self connected, '}'. ^self tclResult = '1' ! value: aBoolean aBoolean ifTrue: [ self tclEval: 'set var', self connected, ' 1' ] ifFalse: [ self tclEval: 'set var', self connected, ' 0' ]. ! ! !BToggle methodsFor: 'private'! initialize: parentWidget | variable | super initialize: parentWidget. self tclEval: self connected, ' configure -anchor nw'. self tclEval: 'variable var', self connected. self variable: 'var', self connected. self backgroundColor: parentWidget backgroundColor ! widgetType ^'checkbutton' ! ! "---------------------------- Images ----------------------------" BPrimitive subclass: #BImage instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BImage comment: ' I can display colorful images.'! BImage defineColorProtocol; defineAccessor: 'gamma' command: 'img%1 cget -gamma' key: #gamma fromStringCode: 'asNumber'; defineMutator: 'gamma' command: 'img%1 configure -gamma %3' key: #gamma toStringCode: 'asFloat printString'; defineAccessor: 'displayWidth' command: 'img%1 cget -width' key: #displayWidth fromStringCode: 'asNumber'; defineMutator: 'displayWidth' command: 'img%1 configure -width %3' key: #displayWidth toStringCode: 'asFloat printString'; defineAccessor: 'displayHeight' command: 'img%1 cget -width' key: #displayHeight fromStringCode: 'asNumber'; defineMutator: 'displayHeight' command: 'img%1 configure -width %3' key: #displayHeight toStringCode: 'asFloat printString'! !BImage class methodsFor: 'instance creation'! new: parent size: aPoint "Answer a new BImage widget laid inside the given parent widget, showing by default a transparent image of aPoint size." ^(self new: parent) displayWidth: aPoint x; displayHeight: aPoint y; blank; yourself ! new: parent image: aFileStream "Answer a new BImage widget laid inside the given parent widget, loading data from the given file (GIF, XPM, PPM are supported)." ^(self new: parent) image: aFileStream; yourself ! new: parent data: aString "Answer a new BImage widget laid inside the given parent widget, loading data from the given string (Base-64 encoded GIF, XPM, PPM are supported)." ^(self new: parent) data: aString; yourself ! ! !BImage methodsFor: 'image management'! blank self tclEval: 'img', self connected, ' blank' ! data: aString self tclEval: 'img', self connected, ' configure -data ', aString asTkImageString ! dither self tclEval: 'img', self connected, ' redither' ! fillRectangle: rectangle color: color self fillFrom: rectangle origin to: rectangle corner color: color ! fillFrom: origin to: corner color: color self tclEval: 'img%1 put { %2 } -to %3 %4' with: self connected with: color with: (origin x printString, ' ', origin y printString) with: (corner x printString, ' ', corner y printString) ! fillFrom: origin extent: extent color: color self fillFrom: origin to: origin + extent color: color ! image: aFileStream self tclEval: 'img', self connected, ' read ', aFileStream name asTkString ! imageHeight self tclEval: 'image height img', self connected. ^self tclResult asInteger ! imageWidth self tclEval: 'image width img', self connected. ^self tclResult asInteger ! lineFrom: origin extent: extent color: color self lineFrom: origin to: origin + extent color: color ! lineFrom: origin to: corner color: color self notYetImplemented ! lineFrom: origin toX: endX color: color self tclEval: 'img%1 put { %2 } -to %3 %4' with: self connected with: color with: (origin x printString, ' ', origin y printString) with: (endX printString, ' ', origin y printString) ! lineFrom: origin toY: endY color: color self tclEval: 'img%1 put { %2 } -to %3 %4' with: self connected with: color with: (origin x printString, ' ', origin y printString) with: (origin x printString, ' ', endY printString) ! lineInside: rectangle color: color self lineFrom: rectangle origin to: rectangle corner color: color ! ! !BImage methodsFor: 'widget protocol'! destroyed primitive isNil ifFalse: [ self tclEval: 'image delete img', self connected. ]. super destroyed ! ! !BImage methodsFor: 'private'! create self tclEval: 'image create photo img', self connected. self create: '-anchor nw -image img', self connected ! setInitialSize "Make the Tk placer's status, the receiver's properties and the window status (as returned by winfo) consistent. Occupy the area indicated by the widget itself, at the top left corner" self x: 0 y: 0. ! widgetType ^'label' ! ! "------------------------------ List box -----------------------------------" BViewport subclass: #BList instanceVariableNames: 'labels items callback' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BList comment: ' I represent a list box from which you can choose one or more elements.'! BList defineFontProtocol; defineColorProtocolWithActivePrefix: 'highlight' tk: 'select'; "#single, #browse, #extended, #multiple" defineAccessor: 'mode' option: 'selectmode' fromStringCode: 'asSymbol'; defineMutator: 'mode' option: 'selectmode' toStringCode: ''; defineAccessor: 'index' command: '%1 index active' key: #index fromStringCode: 'asInteger'! !BList methodsFor: 'callbacks'! itemSelected: receiver at: index stdout nextPutAll: 'List item '; print: index; nextPutAll: ' selected!'; nl. stdout nextPutAll: 'Contents: '; nextPutAll: (items at: index + 1); nl. ! ! !BList methodsFor: 'accessing'! at: anIndex ^items isNil ifTrue: [ labels at: anIndex + 1 ] ifFalse: [ items at: anIndex + 1 ] ! add: string afterIndex: index labels isNil ifTrue: [ index > 0 ifTrue: [ ^self error: 'index out of bounds' ]. labels := OrderedCollection with: string. items := nil ] ifFalse: [ labels add: string afterIndex: index. items notNil ifTrue: [ items add: nil afterIndex: index ]. ]. self tclEval: self connected, ' insert ', index printString, ' ', string asTkString. ^string ! add: string element: element afterIndex: index labels isNil ifTrue: [ index > 0 ifTrue: [ ^self error: 'index out of bounds' ]. labels := OrderedCollection with: string. element isNil ifFalse: [ items := OrderedCollection with: element. ]. ] ifFalse: [ labels add: string afterIndex: index. element notNil | items notNil ifTrue: [ items add: element afterIndex: index ]. ]. self tclEval: self connected, ' insert ', index printString, ' ', string asTkString. ^element isNil ifTrue: [ element ] ifFalse: [ string ] ! addLast: anObject | representation | representation := anObject displayString. labels isNil ifTrue: [ labels := OrderedCollection with: representation. items := anObject isString ifTrue: [ nil ] ifFalse: [ OrderedCollection with: anObject ]. ] ifFalse: [ labels addLast: representation. anObject isString & items isNil ifFalse: [ items addLast: anObject ] ]. self tclEval: self connected, ' insert end ', representation asTkString. ^anObject ! addLast: string element: element labels isNil ifTrue: [ labels := OrderedCollection with: string. element isNil ifFalse: [ items := OrderedCollection with: element ]. ] ifFalse: [ labels addLast: string. element notNil | items notNil ifTrue: [ items addLast: element ]. ]. self tclEval: self connected, ' insert end ', string asTkString. ^element isNil ifTrue: [ element ] ifFalse: [ string ] ! contents: stringCollection ^self contents: stringCollection elements: nil ! contents: stringCollection elements: elementList | stream | (elementList notNil and: [ elementList size ~= stringCollection size ]) ifTrue: [ ^self error: 'label collection must have the same size as element collection' ]. labels := stringCollection asOrderedCollection. items := elementList. items isNil ifFalse: [ items := items asOrderedCollection ]. self tclEval: self connected, ' delete 0 end'. stream := WriteStream on: (String new: 1000). stream nextPutAll: self connected; nextPutAll: ' insert 0'. stringCollection do: [ :each | stream space. stream nextPutAll: each asTkString ]. self tclEval: stream contents. ! do: aBlock items notNil ifTrue: [ items do: aBlock ] ifFalse: [ labels do: aBlock ] ! elements: elementList | stream | labels := elementList collect: [ :each | each displayString ]. items := elementList asOrderedCollection. self tclEval: self connected, ' delete 0 end'. stream := WriteStream on: (String new: 1000). stream nextPutAll: self connected; nextPutAll: ' insert 0'. labels do: [ :each | stream space. stream nextPutAll: each asTkString ]. self tclEval: stream contents. ! isSelected: index self tclEval: self connected, ' selection includes ', index printString. ^self tclResult = '1' ! indexAt: point self tclEval: self connected, ' index @%1,%2' with: point x printString with: point y printString. ^self tclResult asInteger + 1 ! labelAt: anIndex ^labels at: anIndex + 1 ! labelsDo: aBlock labels do: aBlock ! numberOfStrings ^labels size ! removeAtIndex: index | result | result := labels removeAtIndex: index. items isNil ifFalse: [ result := items removeAtIndex: index. ]. self tclEval: self connected, 'delete ', index printString. ^result ! size ^labels size ! ! !BList methodsFor: 'disabled operations'! rowSpacing: spacing ! columnSpacing: spacing ! numberOfColumns: numCols ! usingVerticalLayout ^true ! useVerticalLayout: verticalBool ! ! !BList methodsFor: 'widget protocol'! highlight: index (self mode = #single or: [ self mode = #browse ]) ifTrue: [ self unhighlight ]. self select: index ! select: index self tclEval: '%1 selection set %2 %1 activate %2 %1 see %2' with: self connected with: (index - 1) printString ! show: index self tclEval: self connected, ' see ', (index - 1) printString ! unselect: index self tclEval: self connected, ' selection clear ', (index - 1) printString ! unhighlight self tclEval: self connected, ' selection clear 0 end' ! callback ^callback ! callback: aReceiver message: aString | arguments selector numArgs | selector := aString asSymbol. numArgs := aString asSymbol numArgs. arguments := #(). numArgs = 1 ifTrue: [ arguments := Array new: 1 ]. numArgs = 2 ifTrue: [ arguments := Array with: self with: nil ]. callback := DirectedMessage selector: selector arguments: arguments receiver: aReceiver ! invokeCallback self callback notNil ifTrue: [ self callback arguments isEmpty ifFalse: [ self callback arguments at: self callback arguments size put: (self properties at: #index). ]. self callback send ] ! ! !BList methodsFor: 'private'! create self create: '-highlightthickness 0 -takefocus 1 -bg white -exportselection no'; horizontal: true; vertical: true. "Tcl hack to get the callback upon activate. See analogous trick for text boxes in BText>>#initialize:." self tclEval: ' rename %1 .%1 proc %1 args { if [regexp {^a.*} [lindex $args 0]] { callback %2 invokeCallback: [%1 index [lindex $args 1]] } uplevel .%1 $args }' with: self connected with: self asOop printString. ! initialize: parentWidget super initialize: parentWidget. self properties at: #index put: nil. labels := OrderedCollection new. ! invokeCallback: indexString | index | index := indexString asInteger. "Tk allows a single/browse-selection list box to have no element selected by clicking on the selected item. Thwart its intentions by reselecting that item. This behavior (which is e.g. the one adopted by Windows) seemed more reasonable to me when using a list box in a browser" (self isSelected: index) ifFalse: [ (self mode = #single) | (self mode = #browse) ifTrue: [ (self properties at: #index) isNil ifFalse: [ self tclEval: self connected, ' selection set ', (self properties at: #index) printString. ^self ] ] ]. self properties at: #index put: index. self invokeCallback ! widgetType ^'listbox' ! ! "------------------------------ Window ------------------------------" BForm subclass: #BWindow "Top level container" instanceVariableNames: 'isMapped callback x y width height' classVariableNames: 'TopLevel Grab' poolDictionaries: '' category: 'Graphics-Windows' ! BWindow comment: ' I am the boss. Nothing else could be viewed or interacted with if it wasn''t for me... )):->'! BWindow defineMutator: 'menu' option: 'menu' toStringCode: 'container'; defineAccessor: 'label' command: 'wm title %1' key: #label fromStringCode: ''; defineMutator: 'label' command: 'wm title %1 %3' key: #label toStringCode: ''; defineAccessor: 'resizable' command: 'wm resizable %1' key: #resizable fromStringCode: ' = ''{1 1}'' '; defineMutator: 'resizable' command: 'wm resizable %1 %3 %3' key: #resizable toStringCode: ' asCBooleanValue printString'! !BWindow class methodsFor: 'initialization'! initializeOnStartup self tclEval: 'wm withdraw .'. TopLevel := OrderedCollection new. Grab := nil. ! ! !BWindow class methodsFor: 'instance creation'! new "Answer a new top-level window." ^TopLevel add: (super new: nil) ! new: label "Answer a new top-level window with `label' as its title bar caption." ^self new label: label ! popup: initializationBlock self shouldNotImplement ! ! !BWindow methodsFor: 'accessing'! callback ^callback ! callback: aReceiver message: aString callback := DirectedMessage selector: aString asSymbol arguments: #() receiver: aReceiver ! invokeCallback | result | result := self callback isNil or: [ self callback send ]. result ifTrue: [ self destroy ]. isMapped := result not. ! ! !BWindow methodsFor: 'widget protocol'! centerIn: view self x: view x + (view width // 2) - (self parent width // 2) y: view x + (view height // 2) - (self parent height // 2) ! center | screenSize | screenSize := Blox screenSize. self x: (screenSize x // 2) - (self width // 2) y: (screenSize y // 2) - (self height // 2) ! createToplevelWindow: dummy "for backward compatibility" ! height height isNil ifTrue: [ self cacheWindowSize ]. ^height ! heightAbsolute height isNil ifTrue: [ self cacheWindowSize ]. ^height ! height: anInteger width isNil ifTrue: [ self cacheWindowSize ]. self resetGeometry: '=%1x%2' x: x y: y width: width height: anInteger ! isWindow ^true ! map self isMapped ifTrue: [ self bringToTop. ^self ]. self tclEval: ' wm deiconify %1 update focus [ tk_focusNext %1 ] raise %1' with: self container. self isMapped: true. ! modalMap | previousGrab terminate | previousGrab := Grab. Grab := self connected. self map; tclEval: 'grab set ', Grab. terminate := false. self onDestroySend: #value to: [ terminate := true ]. [ terminate ] whileFalse: [ Processor idle; yield ]. previousGrab isNil ifTrue: [ self tclEval: 'grab release ', Grab ] ifFalse: [ self tclEval: 'grab set ', previousGrab ]. Grab := previousGrab ! isMapped ^isMapped ! state self tclEval: 'wm state ', self connected. ^self tclResult asSymbol ! state: aSymbol self error: 'To set a BWindow''s state, use #map and #unmap.' ! unmap self isMapped ifFalse: [ ^self ]. self tclEval: 'wm withdraw ', self connected. self isMapped: false. ! width width isNil ifTrue: [ self cacheWindowSize ]. ^width ! widthAbsolute width isNil ifTrue: [ self cacheWindowSize ]. ^width ! width: anInteger height isNil ifTrue: [ self cacheWindowSize ]. self resetGeometry: '=%1x%2' x: x y: y width: anInteger height: height ! width: xSize height: ySize self resetGeometry: '=%1x%2' x: x y: y width: xSize height: ySize ! window ^self ! xAbsolute x isNil ifTrue: [ self cacheWindowSize ]. ^x ! x x isNil ifTrue: [ self cacheWindowSize ]. ^x ! x: anInteger y isNil ifTrue: [ self cacheWindowSize ]. self resetGeometry: '+%3+%4' x: anInteger y: y width: width height: height ! x: xPos y: yPos self resetGeometry: '+%3+%4' x: xPos y: yPos width: width height: height ! x: xPos y: yPos width: xSize height: ySize self resetGeometry: '=%1x%2+%3+%4' x: xPos y: yPos width: xSize height: ySize ! yAbsolute y isNil ifTrue: [ self cacheWindowSize ]. ^y ! y y isNil ifTrue: [ self cacheWindowSize ]. ^y ! y: anInteger x isNil ifTrue: [ self cacheWindowSize ]. self resetGeometry: '+%3+%4' x: x y: anInteger width: width height: height ! heightOffset: value self shouldNotImplement ! widthOffset: value self shouldNotImplement ! xOffset: value self shouldNotImplement ! yOffset: value self shouldNotImplement ! ! !BWindow methodsFor: 'private'! create self create: '-takefocus 0'. ! create: options super create: options. self isMapped: false. self bind: '' to: #resized of: self parameters: ''. self tclEval: ' wm withdraw %1 wm protocol %1 WM_DELETE_WINDOW { callback %2 invokeCallback }' with: self connected with: self asOop printString ! destroyed super destroyed. TopLevel remove: self ifAbsent: [ ] ! isMapped: aBoolean isMapped := aBoolean ! resetGeometry: pattern x: xPos y: yPos width: xSize height: ySize | s mapped | s := WriteStream on: (String new: 50). (mapped := self isMapped) ifTrue: [ s nextPutAll: 'wm withdraw ', self connected; nl. self isMapped: false. ]. s nextPutAll: 'wm geometry '; nextPutAll: self connected; space; nextPutAll: pattern; nl; nextPutAll: 'update'. self tclEval: s contents with: xSize printString with: ySize printString with: xPos printString with: yPos printString. x := xPos. y := yPos. width := xSize. height := ySize. mapped ifTrue: [ self map ]. ! cacheWindowSize | stream | self tclEval: 'update; wm geometry ', self container. stream := ReadStream on: self tclResult. width := (stream upTo: $x) asInteger. height := (stream upTo: $+) asInteger. x := (stream upTo: $+) asInteger. y := stream upToEnd asInteger. ! resized self isMapped ifFalse: [ ^self ]. x := y := width := height := nil. ! setInitialSize self x: 0 y: 0 width: 300 height: 300. ! widgetType ^'toplevel' ! ! "Blox extensions " "Written by Brad Diller June 3, 1995" "------------------------------ Transient windows ----------------------" BWindow subclass: #BTransientWindow instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BTransientWindow comment: ' I am almost a boss. I represent a window which is logically linked to another which sits higher in the widget hierarchy, e.g. a dialog box'! !BTransientWindow class methodsFor: 'instance creation'! new self shouldNotImplement ! new: parentWindow "Answer a new transient window attached to the given parent window and with nothing in its title bar caption." ^self basicNew initialize: parentWindow; yourself ! new: label in: parentWindow "Answer a new transient window attached to the given parent window and with `label' as its title bar caption." ^self basicNew initialize: parentWindow; label: label; yourself ! ! !BTransientWindow methodsFor: 'widget protocol'! map super map. self tclEval: 'wm transient ', self connected, ' ', self parent connected. self tclEval: 'wm group ', self connected, ' ', self parent connected ! ! !BTransientWindow methodsFor: 'private'! setWidgetName: parentWidget | unique | unique := '.w', (self asOop printString: 36). parentWidget isNil ifTrue: [ ^unique ]. ^parentWidget parent isNil ifTrue: [ unique ] ifFalse: [ parentWidget parent container copy, unique ]. ! ! "------------------------------ Transient windows ----------------------" BWindow subclass: #BPopupWindow instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BPopupWindow comment: ' I am a pseudo-window that has no decorations and no ability to interact with the user. My main usage, as my name says, is to provide pop-up functionality for other widgets. Actually there should be no need to directly use me - always rely on the #new and #popup: class methods.'! !BPopupWindow methodsFor: 'geometry management'! addChild: w self tclEval: 'place forget ', w container. self tclEval: 'pack ', w container, ' -fill both -side left -padx 1 -pady 1'. ^self basicAddChild: w ! xChild: child ^self x! child: child x: value self x: value! child: child xOffset: value self shouldNotImplement! yChild: child ^self y! child: child y: value self y: value! child: child yOffset: value self shouldNotImplement! widthChild: child "Answer the given child's width in pixels." ^self width! child: child width: value "Set the given child's width." "Only act after #addChild:" self childrenCount = 0 ifTrue: [ ^self ]. self tclEval: 'pack ', child container, ' -expand 1'. self width: value! child: child widthOffset: value self shouldNotImplement! heightChild: child "Answer the given child's height." ^self height! child: child height: value "Set the given child's height." "Only act after #addChild:" self childrenCount = 0 ifTrue: [ ^self ]. self tclEval: 'pack ', child container, ' -expand 1'. self height: value! child: child heightOffset: value self shouldNotImplement! ! !BPopupWindow methodsFor: 'private'! create self create: '-takefocus 0 -background black'; tclEval: 'wm overrideredirect ', self connected, ' 1'; resizable: false ! setInitialSize self cacheWindowSize ! ! "------------------------------ Auto dialog widgets --------------------" BForm subclass: #BDialog instanceVariableNames: 'callbacks initInfo' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BDialog comment: ' I am a facility for implementing dialogs with many possible choices and requests. In addition I provide support for a few platform native common dialog boxes, such as choose-a-file and choose-a-color.'! !BDialog class methodsFor: 'prompters'! chooseColor: parent label: aLabel default: color | result | parent map. self tclEval: 'tk_chooseColor -parent %1 -title %2 -initialcolor %3' with: parent container with: aLabel asTkString with: color asTkString. result := self tclResult. result isEmpty ifTrue: [ result := nil ]. ^result ! chooseFileToOpen: parent label: aLabel default: name defaultExtension: ext types: typeList "e.g. fileName := BDialog chooseFileToOpen: aWindow label: 'Open file' default: nil defaultExtension: 'gif' types: #( ('Text Files' '.txt' '.diz') ('Smalltalk files' '.st') ('C source files' '.c') ('GIF files' '.gif')) " ^self chooseFile: 'Open' parent: parent label: aLabel default: name defaultExtension: ext types: typeList ! chooseFileToSave: parent label: aLabel default: name defaultExtension: ext types: typeList "example: see chooseFileToOpen..." ^self chooseFile: 'Save' parent: parent label: aLabel default: name defaultExtension: ext types: typeList ! ! !BDialog class methodsFor: 'private'! chooseFile: operation parent: parent label: aLabel default: name defaultExtension: ext types: typeList | stream strictMotif file | stream := WriteStream on: String new. stream nextPutAll: 'tk_get'; nextPutAll: operation; nextPutAll: 'File -parent '; nextPutAll: parent container; nextPutAll: ' -title '; nextPutAll: aLabel asTkString; nextPutAll: ' -defaultextension '; nextPutAll: ext asTkString; nextPutAll: ' -filetypes {'. typeList do: [ :each | stream nextPut: ${; nextPutAll: (each at: 1) asTkString; nextPutAll: ' {'. each size > 1 ifTrue: [ each from: 2 to: each size do: [ :type | stream nextPutAll: type; space. ] ]. stream nextPutAll: '}} '. ]. stream nextPutAll: '{"All files" * }}'. (name notNil and: [ name notEmpty ]) ifTrue: [ stream nextPutAll: ' -initialfile '; nextPutAll: name asTkString ]. strictMotif := BText emacsLike. BText emacsLike: (Blox platform ~= 'unix'). parent map. self tclEval: stream contents. file := self tclResult. file isEmpty ifTrue: [ file := nil ]. BText emacsLike: strictMotif. ^file ! ! !BDialog class methodsFor: 'instance creation'! new: parent "Answer a new dialog handler (containing a label widget and some button widgets) laid out within the given parent window. The label widget, when it is created, is empty." ^self basicNew initInfo: '' -> nil; initialize: parent ! new: parent label: aLabel "Answer a new dialog handler (containing a label widget and some button widgets) laid out within the given parent window. The label widget, when it is created, contains aLabel." ^self basicNew initInfo: aLabel -> nil; initialize: parent ! new: parent label: aLabel prompt: aString "Answer a new dialog handler (containing a label widget, some button widgets, and an edit window showing aStrnig by default) laid out within the given parent window. The label widget, when it is created, contains aLabel." ^self basicNew initInfo: aLabel -> aString; initialize: parent ! ! !BDialog methodsFor: 'accessing'! addButton: aLabel receiver: anObject index: anInt callbacks addLast: (DirectedMessage selector: #dispatch: arguments: (Array with: anInt) receiver: anObject). self addButton: aLabel. ! addButton: aLabel receiver: anObject message: aSymbol callbacks addLast: (DirectedMessage selector: aSymbol arguments: #() receiver: anObject). self addButton: aLabel. ! contents self tclEval: 'return ${var', self connected, '}'. ^self tclResult ! contents: newText self tclEval: 'set var', self connected, ' ', newText asTkString ! ! !BDialog methodsFor: 'widget protocol'! center self parent center ! centerIn: view self parent centerIn: view ! destroyed self tclEval: 'catch { unset var', self connected, '}'. super destroyed. ! invokeCallback: index (callbacks at: index asInteger) send. self parent destroy ! loop self parent width: (self parent width min: 200). self parent modalMap. ! ! !BDialog methodsFor: 'private'! addButton: aLabel self tclEval: 'button %1.buttons.b%2 -text %3 -highlightthickness 0 -takefocus 1 -command { callback %4 "invokeCallback:" %2 destroy %1 } pack %1.buttons.b%2 -side left -expand 1' with: self container with: callbacks size printString with: aLabel asTkString with: self asOop printString. ! create super create. self tclEval: ' label %1.msg -padx 5 -pady 5 -anchor nw -text ', initInfo key asTkString, ' place %1.msg -x 0.0 -y 0.0 -relwidth 1.0 %1.msg configure -background [ %1 cget -background ] frame %1.buttons -highlightthickness 0 -takefocus 0 %1.buttons configure -background [ %1 cget -background ] place %1.buttons -anchor sw -x 0.0 -rely 1.0 -relwidth 1.0 -height 14m lower %1.buttons lower %1.msg' with: self connected. initInfo value isNil ifTrue: [ ^self ]. self tclEval: ' set var%1 %2 entry %1.text -textvariable var%1 -highlightthickness 0 -takefocus 1 place %1.text -in %1.msg -x 5 -y 5 -width -10 -rely 1.0 -relwidth 1.0 raise %1.text' with: self connected with: initInfo value asTkString. ! initialize: parentWidget super initialize: parentWidget. callbacks := OrderedCollection new. ! initInfo: assoc initInfo := assoc ! ! "------------------------------ Menu Bar ------------------------------" BMenuObject subclass: #BMenuBar instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BMenuBar comment: ' I am the Menu Bar, the top widget in a full menu structure.'! !BMenuBar methodsFor: 'accessing'! add: aMenu aMenu create. ^self addChild: aMenu ! remove: aMenu self tclEval: 'delete ', aMenu connected ! ! !BMenuBar methodsFor: 'private'! container ^primitive ! connected ^primitive ! initialize: parentWidget super initialize: parentWidget. primitive := self parent isNil ifTrue: [ '.popup' ] ifFalse: [ self parent container, '.menu' ]. "BMenuBar is NOT a BPrimitive, so it has to explicitly create itself" self tclEval: 'menu ', self connected, ' -tearoff 0'. self parent isNil ifFalse: [ self parent menu: self ] ! ! "------------------------------ Menu ------------------------------" BMenuObject subclass: #BMenu instanceVariableNames: 'label exists childrensUnderline' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BMenu comment: ' I am the Menu, which groups together commands in a menu structure.'! !BMenu class methodsFor: 'instance creation'! new: parent label: label "Add a new menu to the parent window's menu bar, with `label' as its caption (for popup menus, parent is the widget over which the menu pops up as the right button is pressed)." ^self basicNew initialize: parent; label: label; yourself ! ! !BMenu methodsFor: 'accessing'! exists ^exists ! label: value label := value. exists ifTrue: [ self tclEval: self connected, ' configure -title ', (value asTkString) ]. ! label ^label ! ! !BMenu methodsFor: 'callback registration'! addLine ^self addMenuItemFor: #() notifying: self "self is dummy" ! addMenuItemFor: anArray notifying: receiver "Receiver will be sent the callback messages. anArray is something that responds to at: and size. Possible types are: #() insert a seperator line #(name) create a menu item with name, but no callback #(name symbol) create a menu item with the given name and no parameter callback. #(name symbol arg) create a menu item with the given name and one parameter callback." | item | item := self newMenuItemFor: anArray notifying: receiver. ! callback: receiver using: selectorPairs "Receiver will be sent the callback messages. Selector pairs is a collection of Arrays (or something that responds to at: and size). Possible types are: #() insert a seperator line #(name) create a menu item with name, but no callback #(name symbol) create a menu item with the given name and no parameter callback. #(name symbol arg) create a menu item with the given name and one parameter callback." | item | selectorPairs do: [ :pair | item := self newMenuItemFor: pair notifying: receiver. exists ifTrue: [ item create ]. ]. ! destroy self parent remove: self. ! ! !BMenu methodsFor: 'private'! addChild: menuItem menuItem menuIndex: self childrenCount. super addChild: menuItem. self exists ifTrue: [ menuItem create ]. ^menuItem ! container ^primitive ! connected ^primitive ! create | s | s := WriteStream on: (String new: 80). s nextPutAll: 'menu '; nextPutAll: self connected; nextPutAll: ' -tearoff 0'; nl; nextPutAll: self parent container; nextPutAll: ' add cascade -label '; nextPutAll: self label asTkString; nextPutAll: ' -underline 0 -menu '; nextPutAll: self connected. self tclEval: s contents. "Set the title for torn-off menus" self label: self label. self childrenDo: [ :each | each create ]. exists := true. ! initialize: parentWidget super initialize: parentWidget. label := ''. exists := false. primitive := '%1.w%2' bindWith: self parent container with: (self asOop printString: 36). ! newMenuItemFor: pair notifying: receiver | item | pair size = 0 ifTrue: [ ^BMenuItem new: self ]. item := BMenuItem new: self label: (pair at: 1). pair size = 1 ifTrue: [ ^item ]. pair size = 2 ifTrue: [ ^item callback: receiver message: (pair at: 2) ]. ^item callback: receiver message: (pair at: 2) argument: (pair at: 3) ! underline: label childrensUnderline isNil ifTrue: [ childrensUnderline := ByteArray new: 256 ]. label doWithIndex: [ :each :index || ascii | ascii := each asUppercase value + 1. (childrensUnderline at: ascii) = 0 ifTrue: [ childrensUnderline at: ascii put: 1. ^index - 1 ] ]. ^0 ! ! "------------------------------ Popup Menu ------------------------------" BMenu subclass: #BPopupMenu instanceVariableNames: '' classVariableNames: 'PopupMenuBar' poolDictionaries: '' category: 'Graphics-Windows' ! BMenu comment: ' I am a Menu that pops up on another window. A handy shortcut, surely'! !BPopupMenu class methodsFor: 'accessing'! initializeOnStartup PopupMenuBar := nil ! popupMenuBar PopupMenuBar isNil ifTrue: [ PopupMenuBar := BMenuBar new: nil ]. ^PopupMenuBar ! ! !BPopupMenu methodsFor: 'widget protocol'! popup self tclEval: 'event generate %1 ' with: self parent connected ! ! !BPopupMenu methodsFor: 'private'! initialize: parentWindow super initialize: self class popupMenuBar. self parent add: self. parentWindow bind: '' to: #popup:y: of: self parameters: '%X %Y'. parentWindow bind: '' to: #popup:y: of: self parameters: '[expr 2+[winfo rootx %W]] [expr 2+[winfo rooty %W]]'. ! popup: x y: y "Note that x and y are strings!" self tclEval: 'tk_popup ', self connected, ' ', x, ' ', y ! ! "------------------------------ Menu Item ------------------------------" BMenuObject subclass: #BMenuItem instanceVariableNames: 'index callback createCode' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BMenuItem comment: ' I am the tiny and humble Menu Item, a single command choice in the menu structure. But if it wasn''t for me, nothing could be done... eh eh eh!!'! !BMenuItem class methodsFor: 'instance creation'! new: parent label: label "Add a new menu item to the specified menu (parent) , with `label' as its caption." ^self basicNew initialize: parent label: label ! new: parent "Add a new separator item to the specified menu." ^self basicNew initialize: parent ! ! !BMenuItem methodsFor: 'accessing'! callback ^callback ! callback: aReceiver message: aSymbol callback := DirectedMessage selector: aSymbol asSymbol arguments: #() receiver: aReceiver ! callback: aReceiver message: aSymbol argument: anObject callback := DirectedMessage selector: aSymbol asSymbol arguments: (Array with: anObject) receiver: aReceiver ! invokeCallback self callback isNil ifFalse: [ self callback send ] ! label: value (self properties at: #label) isNil ifTrue: [ ^self error: 'no label for separator lines' ]. self parent exists ifTrue: [ self tclEval: self container, ' entryconfigure ', self connected, ' -label ', value asTkString ]. self properties at: #label put: value ! label ^self properties at: #label ! ! !BMenuItem methodsFor: 'private'! connected ^index ! container ^self parent container ! create | label | label := self label ifNil: [ '' ] ifNotNil: [ :lab | lab asTkString ]. self tclEval: createCode with: label with: self widgetType. createCode := '' "free some memory" ! initialize: parentWidget label: label | s | super initialize: parentWidget. s := WriteStream on: (String new: 80). s nextPutAll: self container; nextPutAll: ' add %2 -label %1 -underline '; print: (self parent underline: label); nextPutAll: ' -command { callback '; print: self asOop; nextPutAll: ' invokeCallback }'. createCode := s contents. self properties at: #label put: label. parent addChild: self. parent exists ifTrue: [ self create ]. ! initialize: parentWidget super initialize: parentWidget. createCode := self container, ' add separator'. self properties at: #label put: nil. parent addChild: self. ! widgetType ^'command' ! menuIndex: anIndex index := anIndex printString ! ! "-------------------------- Checkbox menu item -------------------------" BMenuItem subclass: #BCheckMenuItem instanceVariableNames: 'status' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! !BCheckMenuItem class methodsFor: 'instance creation'! new: parent self shouldNotImplement ! ! !BCheckMenuItem methodsFor: 'accessing'! invokeCallback self properties removeKey: #value ifAbsent: [ ]. self callback isNil ifFalse: [ self callback send ] ! value: aBoolean self properties at: #value put: aBoolean. self tclEval: 'set ', self variable, self valueString. ! value ^self properties at: #value ifAbsentPut: [ false ] ! ! !BCheckMenuItem methodsFor: 'private'! create super create. self tclEval: '%1 entryconfigure %2 -onvalue 1 -offvalue 0 -variable %3' with: self container with: self connected with: self variable ! destroyed self tclEval: 'unset var', self container, self connected. super destroyed. ! widgetType ^'checkbutton' ! variable ^('var', self connected, self container) copyWithout: $. ! valueString ^self value ifTrue: [ ' 1' ] ifFalse: [ ' 0' ] ! !