"====================================================================== | | Smalltalk Tk-based GUI building blocks (abstract 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. | ======================================================================" "----------------------------------- Gui class ---------------------------" Object subclass: #Gui instanceVariableNames: 'blox' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! Gui comment: ' I am a small class which serves as a base for complex objects which expose an individual protocol but internally use a Blox widget for creating their user interface.'! !Gui methodsFor: 'accessing' ! blox "Return instance of blox subclass which implements window" ^blox. ! blox: aBlox "Set instance of blox subclass which implements window" blox := aBlox. ! ! "------------------------------ Event handling ------------------------" Object subclass: #BEventTarget instanceVariableNames: 'eventReceivers' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BEventTarget comment: ' I track all the event handling procedures that you apply to an object.'! !BEventTarget methodsFor: 'intercepting events'! addEventSet: aBEventSetSublass "Add to the receiver the event handlers implemented by an instance of aBEventSetSubclass. Answer the new instance of aBEventSetSublass" ^self registerEventReceiver: (aBEventSetSublass new: self) ! onAsciiKeyEventSend: aSelector to: anObject "When an ASCII key is pressed and the receiver has the focus, send the 1-argument message identified by aSelector to anObject, passing to it a Character" aSelector numArgs = 1 ifFalse: [ ^self invalidArgsError: '1' ]. self registerEventReceiver: anObject. ^self bind: '' to: #sendKeyEvent:oop:selector: of: self parameters: '*%A* ', anObject asOop printString, ' ', aSelector asTkString ! onDestroySend: aSelector to: anObject "When the receiver is destroyed, send the unary message identified by aSelector to anObject." aSelector numArgs = 0 ifFalse: [ ^self invalidArgsError: '0' ]. ^self bind: '' to: aSelector of: anObject parameters: '' ! onFocusEnterEventSend: aSelector to: anObject "When the focus enters the receiver, send the unary message identified by aSelector to anObject." aSelector numArgs = 0 ifFalse: [ ^self invalidArgsError: '0' ]. ^self bind: '' to: aSelector of: anObject parameters: '' ! onFocusLeaveEventSend: aSelector to: anObject "When the focus leaves the receiver, send the unary message identified by aSelector to anObject." aSelector numArgs = 0 ifFalse: [ ^self invalidArgsError: '0' ]. ^self bind: '' to: aSelector of: anObject parameters: '' ! onKeyEvent: key send: aSelector to: anObject "When the given key is pressed and the receiver has the focus, send the unary message identified by aSelector to anObject. Examples for key are: 'Ctrl-1', 'Alt-X', 'Meta-plus', 'enter'. The last two cases include example of special key identifiers; these include: 'backslash', 'exclam', 'quotedbl', 'dollar', 'asterisk', 'less', 'greater', 'asciicircum' (caret), 'question', 'equal', 'parenleft', 'parenright', 'colon', 'semicolon', 'bar' (pipe sign), 'underscore', 'percent', 'minus', 'plus', 'BackSpace', 'Delete', 'Insert', 'Return', 'End', 'Home', 'Prior' (Pgup), 'Next' (Pgdn), 'F1'..'F24', 'Caps_Lock', 'Num_Lock', 'Tab', 'Left', 'Right', 'Up', 'Down'. There are in addition four special identifiers which map to platform-specific keys: '', '', '', '' (all with the angular brackets!)." aSelector numArgs = 0 ifFalse: [ ^self invalidArgsError: '0' ]. ^self bind: (self getKeyPressEventName: key) to: aSelector of: anObject parameters: '' ! onKeyEventSend: aSelector to: anObject "When a key is pressed and the receiver has the focus, send the 1-argument message identified by aSelector to anObject. The pressed key will be passed as a String parameter; some of the keys will send special key identifiers such as those explained in the documentation for #onKeyEvent:send:to: Look at the #eventTest test program in the BloxTestSuite to find out the parameters passed to such an event procedure" aSelector numArgs = 1 ifFalse: [ ^self invalidArgsError: '1' ]. ^self bind: '' to: aSelector of: anObject parameters: '%K' ! onKeyUpEventSend: aSelector to: anObject "When a key has been released and the receiver has the focus, send the 1-argument message identified by aSelector to anObject. The released key will be passed as a String parameter; some of the keys will send special key identifiers such as those explained in the documentation for #onKeyEvent:send:to: Look at the #eventTest test program in the BloxTestSuite to find out the parameters passed to such an event procedure" aSelector numArgs = 1 ifFalse: [ ^self invalidArgsError: '1' ]. ^self bind: '' to: aSelector of: anObject parameters: '%K' ! onMouseDownEvent: button send: aSelector to: anObject "When the given button is pressed on the mouse, send the 1-argument message identified by aSelector to anObject. The mouse position will be passed as a Point." aSelector numArgs = 1 ifFalse: [ ^self invalidArgsError: '1' ]. self registerEventReceiver: anObject. ^self bind: '' to: #sendPointEvent:y:oop:selector: of: self parameters: '%x %y ', anObject asOop printString, ' ', aSelector asTkString ! onMouseDownEventSend: aSelector to: anObject "When a button is pressed on the mouse, send the 2-argument message identified by aSelector to anObject. The mouse position will be passed as a Point in the first parameter, the button number will be passed as an Integer in the second parameter." aSelector numArgs = 2 ifFalse: [ ^self invalidArgsError: '2' ]. self registerEventReceiver: anObject. ^self bind: '' to: #sendPointEvent:y:button:oop:selector: of: self parameters: '%x %y %b ', anObject asOop printString, ' ', aSelector asTkString ! onMouseDoubleEvent: button send: aSelector to: anObject "When the given button is double-clicked on the mouse, send the 1-argument message identified by aSelector to anObject. The mouse position will be passed as a Point." aSelector numArgs = 1 ifFalse: [ ^self invalidArgsError: '1' ]. self registerEventReceiver: anObject. ^self bind: '' to: #sendPointEvent:y:oop:selector: of: self parameters: '%x %y ', anObject asOop printString, ' ', aSelector asTkString ! onMouseDoubleEventSend: aSelector to: anObject "When a button is double-clicked on the mouse, send the 2-argument message identified by aSelector to anObject. The mouse position will be passed as a Point in the first parameter, the button number will be passed as an Integer in the second parameter." aSelector numArgs = 2 ifFalse: [ ^self invalidArgsError: '2' ]. self registerEventReceiver: anObject. ^self bind: '' to: #sendPointEvent:y:button:oop:selector: of: self parameters: '%x %y %b ', anObject asOop printString, ' ', aSelector asTkString ! onMouseEnterEventSend: aSelector to: anObject "When the mouse enters the widget, send the unary message identified by aSelector to anObject." aSelector numArgs = 0 ifFalse: [ ^self invalidArgsError: '0' ]. ^self bind: '' to: aSelector of: anObject parameters: '' ! onMouseLeaveEventSend: aSelector to: anObject "When the mouse leaves the widget, send the unary message identified by aSelector to anObject." aSelector numArgs = 0 ifFalse: [ ^self invalidArgsError: '0' ]. ^self bind: '' to: aSelector of: anObject parameters: '' ! onMouseMoveEvent: button send: aSelector to: anObject "When the mouse is moved while the given button is pressed on the mouse, send the 1-argument message identified by aSelector to anObject. The mouse position will be passed as a Point." aSelector numArgs = 1 ifFalse: [ ^self invalidArgsError: '1' ]. self registerEventReceiver: anObject. ^self bind: '' to: #sendPointEvent:y:oop:selector: of: self parameters: '%x %y ', anObject asOop printString, ' ', aSelector asTkString ! onMouseMoveEventSend: aSelector to: anObject "When the mouse is moved, send the 1-argument message identified by aSelector to anObject. The mouse position will be passed as a Point." aSelector numArgs = 1 ifFalse: [ ^self invalidArgsError: '1' ]. self registerEventReceiver: anObject. ^self bind: '' to: #sendPointEvent:y:oop:selector: of: self parameters: '%x %y ', anObject asOop printString, ' ', aSelector asTkString ! onMouseTripleEvent: button send: aSelector to: anObject "When the given button is triple-clicked on the mouse, send the 1-argument message identified by aSelector to anObject. The mouse position will be passed as a Point." aSelector numArgs = 1 ifFalse: [ ^self invalidArgsError: '1' ]. self registerEventReceiver: anObject. ^self bind: '' to: #sendPointEvent:y:oop:selector: of: self parameters: '%x %y ', anObject asOop printString, ' ', aSelector asTkString ! onMouseTripleEventSend: aSelector to: anObject "When a button is triple-clicked on the mouse, send the 2-argument message identified by aSelector to anObject. The mouse position will be passed as a Point in the first parameter, the button number will be passed as an Integer in the second parameter." aSelector numArgs = 2 ifFalse: [ ^self invalidArgsError: '2' ]. self registerEventReceiver: anObject. ^self bind: '' to: #sendPointEvent:y:button:oop:selector: of: self parameters: '%x %y %b ', anObject asOop printString, ' ', aSelector asTkString ! onMouseUpEvent: button send: aSelector to: anObject "When the given button is released on the mouse, send the 1-argument message identified by aSelector to anObject. The mouse position will be passed as a Point." aSelector numArgs = 1 ifFalse: [ ^self invalidArgsError: '1' ]. self registerEventReceiver: anObject. ^self bind: '' to: #sendPointEvent:y:oop:selector: of: self parameters: '%x %y ', anObject asOop printString, ' ', aSelector asTkString ! onMouseUpEventSend: aSelector to: anObject "When a button is released on the mouse, send the 2-argument message identified by aSelector to anObject. The mouse position will be passed as a Point in the first parameter, the button number will be passed as an Integer in the second parameter." aSelector numArgs = 2 ifFalse: [ ^self invalidArgsError: '2' ]. self registerEventReceiver: anObject. ^self bind: '' to: #sendPointEvent:y:button:oop:selector: of: self parameters: '%x %y %b ', anObject asOop printString, ' ', aSelector asTkString ! onResizeSend: aSelector to: anObject "When the receiver is resized, send the 1-argument message identified by aSelector to anObject. The new size will be passed as a Point." aSelector numArgs = 1 ifFalse: [ ^self invalidArgsError: '1' ]. self registerEventReceiver: anObject. ^self bind: '' to: #sendPointEvent:y:oop:selector: of: self parameters: '%w %h ', anObject asOop printString, ' ', aSelector asTkString ! ! !BEventTarget methodsFor: 'private'! bind: event to: aSymbol of: anObject parameters: params "Private - Register the given event, to be passed to anObject via the aSymbol selector with the given parameters. Also avoid that anObject is garbage collected as long as the receiver exists." self registerEventReceiver: anObject; primBind: event to: aSymbol of: anObject parameters: params ! getKeyPressEventName: key "Private - Given the key passed to a key event installer method, answer the KeyPress event name as required by Tcl." | platform mod keySym | keySym := key isCharacter ifTrue: [ String with: key ] ifFalse: [ key ]. (keySym at: 1) = $< ifTrue: [ ^'<', keySym, '>' ]. (keySym includes: $-) ifFalse: [ ^'' ]. mod := (ReadStream on: key) upTo: $-. keySym := key copyFrom: mod size + 2 to: key size. platform := Blox platform. (mod = 'Meta') & (platform ~~ #unix) ifTrue: [ mod := 'Alt' ]. (mod = 'Alt') & (platform == #unix) ifTrue: [ mod := 'Meta' ]. (mod = 'Alt') & (platform == #macintosh) ifTrue: [ mod := 'Option' ]. (mod = 'Ctrl') & (platform == #macintosh) ifTrue: [ mod := 'Cmd' ]. ^'<', mod, '-KeyPress-', keySym, '>' ! invalidArgsError: expected "Private - Raise an error (as one could expect...) What is not so expected is that the expected argument is a string." ^self error: 'invalid number of arguments, expected ', expected ! primBind: event to: aSymbol of: anObject parameters: params "Private - Register the given event, to be passed to anObject via the aSymbol selector with the given parameters" self subclassResponsibility ! registerEventReceiver: anObject "Private - Avoid that anObject is garbage collected as long as the receiver exists." eventReceivers isNil ifTrue: [ eventReceivers := IdentitySet new ]. ^eventReceivers add: anObject ! sendKeyEvent: key oop: oop selector: sel "Private - Filter ASCII events from Tcl to Smalltalk. We receive either *{}* for a non-ASCII char or *A* for an ASCII char, where A is the character. In the first case the event is eaten, in the second it is passed to a Smalltalk method" "key printNl. oop asInteger asObject printNl. '---' printNl." key size = 3 ifTrue: [ oop asInteger asObject perform: sel asSymbol with: (key at: 2) ] ! sendPointEvent: x y: y oop: oop selector: sel "Private - Filter mouse events from Tcl to Smalltalk. We receive two strings, we convert them to a Point and then pass them to a Smalltalk method" "oop printNl. oop asInteger asObject printNl. '---' printNl." oop asInteger asObject perform: sel asSymbol with: (x asInteger @ y asInteger) ! sendPointEvent: x y: y button: button oop: oop selector: sel "Private - Filter mouse events from Tcl to Smalltalk. We receive three strings, we convert them to a Point and a Number, then pass them to a Smalltalk method" "oop printNl. oop asInteger asObject printNl. '---' printNl." oop asInteger asObject perform: sel asSymbol with: (x asInteger @ y asInteger) with: button asInteger ! ! "------------------------------ Event sets ----------------------------" BEventTarget subclass: #BEventSet instanceVariableNames: 'widget' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BEventSet comment: ' I combine event handlers and let you apply them to many objects. Basically, you derive a class from me, override the #initialize: method to establish the handlers, then use the #addEventSet: method understood by every Blox class to add the event handlers specified by the receiver to the object.'! !BEventSet class methodsFor: 'initializing'! new self shouldNotImplement ! new: widget "Private - Create a new event set object that will attach to the given widget. Answer the object. Note: this method should be called by #addEventSet:, not directly" ^self basicNew initialize: widget; yourself ! ! !BEventSet methodsFor: 'accessing'! widget "Answer the widget to which the receiver is attached." ^widget ! ! !BEventSet methodsFor: 'initializing'! initialize: aBWidget "Initialize the receiver's event handlers to attach to aBWidget. You can override this of course, but don't forget to call the superclass implementation first." widget := aBWidget. ! ! !BEventSet methodsFor: 'private'! primBind: event to: aSymbol of: anObject parameters: params "Private - Register the given event, to be passed to anObject via the aSymbol selector with the given parameters; this method is simply forwarded to the attached widget" ^self widget primBind: event to: aSymbol of: anObject parameters: params ! ! " -------------------------------- Tcl interface ---------------------" BEventTarget subclass: #Blox instanceVariableNames: 'primitive properties parent children' classVariableNames: 'DoDispatchEvents Interp ClipStatus Debug Platform' poolDictionaries: '' category: 'Graphics-Windows' ! Blox comment: ' I am the superclass for every visible user interface object (excluding canvas items, which are pretty different). I provide common methods and a simple Tcl interface for internal use. In addition, I expose class methods that do many interesting event-handling things. NOTE: some of the methods (notably geometry methods) may not be suitable for all Blox subclasses and may be included only for backwards compatibility towards 1.1.5 BLOX. You should use geometry methods only for subclasses of BWidget.'! Blox class defineCFunc: 'tclInit' withSelectorArgs: 'tclInit' returning: #cObject args: #() ! Blox class defineCFunc: 'Tcl_Eval' withSelectorArgs: 'evalIn: interp tcl: cmd' returning: #int args: #(cObject string) ! Blox class defineCFunc: 'Tcl_GetStringResult' withSelectorArgs: 'resultIn: interp' returning: #string args: #(cObject) ! Blox class defineCFunc: 'bloxIdle' withSelectorArgs: 'idle' returning: #void args: #() ! !Blox class methodsFor: 'private - Tcl'! debug "Private - Answer whether Tcl code is output on the standard output" ^Debug ! debug: aBoolean "Private - Set whether Tcl code is output on the standard output" Debug := aBoolean ! tclEval: tclCode "Private - Evaluate the given Tcl code; if it raises an exception, raise it as a Smalltalk error" self debug ifTrue: [ stdout nextPutAll: tclCode; nl ]. (self evalIn: Interp tcl: tclCode) = 1 ifTrue: [ self tclResult printNl. ^self error: self tclResult ]. ! tclResult "Private - Return the result code for Tcl, as a Smalltalk String." ^self resultIn: Interp ! ! !Blox methodsFor: 'private - Tcl'! tclEval: tclCode "Private - Evaluate the given Tcl code; if it raises an exception, raise it as a Smalltalk error" Blox debug ifTrue: [ stdout nextPutAll: tclCode; nl ]. (Blox evalIn: Interp tcl: tclCode) = 1 ifTrue: [ ^self error: self tclResult ]. ! tclEval: tclCode with: arg1 self tclEval: tclCode withArguments: (Array with: arg1) ! tclEval: tclCode with: arg1 with: arg2 self tclEval: tclCode withArguments: (Array with: arg1 with: arg2) ! tclEval: tclCode with: arg1 with: arg2 with: arg3 self tclEval: tclCode withArguments: (Array with: arg1 with: arg2 with: arg3) ! tclEval: tclCode with: arg1 with: arg2 with: arg3 with: arg4 self tclEval: tclCode withArguments: (Array with: arg1 with: arg2 with: arg3 with: arg4) ! tclEval: tclCode withArguments: anArray | char result wasPercent | result := WriteStream on: (String new: tclCode size * 2). wasPercent := false. 1 to: tclCode size do: [:i | char := tclCode at: i. wasPercent ifTrue: [ char = $% ifTrue: [ result nextPut: char ] ifFalse: [ result nextPutAll: (anArray at: char digitValue) ]. wasPercent := false ] ifFalse: [ (wasPercent := (char = $%)) ifFalse: [ result nextPut: char ] ] ]. result nextPut: 0 asCharacter. Blox tclEval: result collection ! tclResult "Private - Return the result code for Tcl, as a Smalltalk String." ^Blox resultIn: Interp ! ! " -------------------------------- 'meta' methods ---------------------" !Blox class methodsFor: 'creating Tk interface methods'! defineMutator: keyword option: tkOption toStringCode: extraCode "Private - Produce code to set a widget option, like... self tclEval: self connected, ' configure -label ' , (value asTkString). self properties at: #label put: value" self defineMutator: keyword command: '%1 configure -', tkOption, ' %3' key: tkOption toStringCode: extraCode ! defineAccessor: keyword option: tkOption fromStringCode: extraCode "Private - Produce code to retrieve a widget option, like... self properties at: #label ifPresent: [ :value | ^value ]. self tclEval: '%1 cget -label' with: self connected with: self container. ^self properties at: #label put: (self tclResult )" self defineAccessor: keyword command: '%1 cget -', tkOption key: tkOption fromStringCode: extraCode ! defineMutator: keyword command: cmd key: key toStringCode: extraCode "Private - produce code to set a widget option; the Smalltalk method is named `keyword:' and refers to a property named `key'. The Tcl command issued is `cmd', with %1 replaced by the connected Tk widget, %2 by the container, %3 by the Tcl string obtained by the parameter through evaluation of `extraCode'." | s | s _ '%1: value "Please refer to OptionDocumentation for %1" self tclEval: %2 with: self connected with: self container with: (value %3 asTkString). self properties at: #%4 put: value' bindWith: keyword with: cmd storeString with: extraCode with: key. "stdout nextPutAll: s; nl; nl." self compile: s classified: 'accessing' ! defineAccessor: keyword command: cmd key: key fromStringCode: extraCode "Private - produce code to retrieve a widget option; the Smalltalk method is named like `keyword' and refers to a property named `key'. The Tcl command issued is `cmd', with %1 replaced by the connected Tk widget and %2 by the container; if the code is executed, its result is passed to `extraCode' (which is sent to a String) and then put in the properties dictionary." | s | s _ '%1 "Please refer to OptionDocumentation for %1" self properties at: #%4 ifPresent: [ :value | ^value ]. self tclEval: %2 with: self connected with: self container. ^self properties at: #%4 put: (self tclResult %3)' bindWith: keyword with: cmd storeString with: extraCode with: key. "stdout nextPutAll: s; nl; nl." self compile: s classified: 'accessing' ! defineColorProtocol "Private - Define the `{fore|back}groundColor:', `{fore|back}groundColor' methods" self defineAccessor: 'foregroundColor' option: 'foreground' fromStringCode: ''; defineAccessor: 'backgroundColor' option: 'background' fromStringCode: ''; defineMutator: 'foregroundColor' option: 'foreground' toStringCode: ''; defineMutator: 'backgroundColor' option: 'background' toStringCode: ''. ! defineColorProtocolWithActivePrefix: active tk: tkActive "Private - Define the `{fore|back}groundColor:', `{fore|back}groundColor', `xxxx{Fore|Back}ground', `xxxx{Fore|Back}ground:' methods, where xxxx is replaced by the contents of the `active' parameter (a String)." self defineColorProtocol; defineAccessor: active, 'Foreground' option: tkActive, 'foreground' fromStringCode: ''; defineAccessor: active, 'Background' option: tkActive, 'background' fromStringCode: ''; defineMutator: active, 'Foreground' option: tkActive, 'foreground' toStringCode: ''; defineMutator: active, 'Background' option: tkActive, 'background' toStringCode: '' ! ! " -------------------------------- generic methods ---------------------" !Blox class methodsFor: 'instance creation'! new self shouldNotImplement ! new: parent "Create a new widget of the type identified by the receiver, inside the given parent widget. Answer the new widget" ^self basicNew initialize: parent ! ! !Blox class methodsFor: 'event dispatching'! onStartup "Initialize the Tcl and Blox environments; executed automatically on startup." | initResult | Debug isNil ifTrue: [ Processor idleAdd: [ self idle ]. Debug := false. ]. initResult := self tclInit. initResult isNil ifTrue: [ ^self ]. initResult address = 0 ifTrue: [ ^self ]. Interp := initResult. DoDispatchEvents := 0. ClipStatus := nil. Blox withAllSubclassesDo: [ :each | (each class includesSelector: #initializeOnStartup) ifTrue: [ each initializeOnStartup ] ]. ! dispatchEvents "Dispatch some events; return instantly if another dispatching loop is started, else loop until the number of calls to #dispatchEvents balance the number of calls to #terminateMainLoop." DoDispatchEvents := DoDispatchEvents + 1. (ClipStatus isKindOf: Boolean) ifTrue: [ ^self ]. ClipStatus isString ifTrue: [ self clipboard: ClipStatus ]. ClipStatus := ClipStatus notNil. [ DoDispatchEvents > 0 ] whileTrue: [ Processor idle; yield ]. "If we're outside the event loop, Tk for Windows is unable to render the clipboard and locks up the clipboard viewer app. Anyway save the contents for the next time we'll start a message loop" ClipStatus := ClipStatus ifTrue: [ self clearClipboard ] ifFalse: [ nil ] ! dispatchEvents: mainWindow "Dispatch some events; return instantly if another dispatching loop is started, else loop until the number of calls to #dispatchEvents balance the number of calls to #terminateMainLoop. In addition, set an event handler that will call #terminateMainLoop upon destruction of the `mainWindow' widget (which can be any kind of BWidget, but will be typically a BWindow)." mainWindow onDestroySend: #terminateMainLoop to: self. self dispatchEvents ! terminateMainLoop "Terminate the event dispatching loop if this call to #terminateMainLoop balances the number of calls to #dispatchEvents. Answer whether the calls are balanced." DoDispatchEvents > 0 ifTrue: [ DoDispatchEvents := DoDispatchEvents - 1 ]. ^DoDispatchEvents == 0 ! ! !Blox class methodsFor: 'utility'! beep "Produce a bell" self tclEval: 'bell' ! clearClipboard "Clear the clipboard, answer its old contents." | contents | contents := self tclEval: 'selection get -selection CLIPBOARD'. self tclEval: 'clipboard clear'. ClipStatus := ClipStatus isString ifTrue: [ nil ] ifFalse: [ false ]. ^contents ! clipboard "Retrieve the text in the clipboard." self tclEval: 'selection get -selection CLIPBOARD'. ^self tclResult ! clipboard: aString "Set the contents of the clipboard to aString (or empty the clipboard if aString is nil)." self tclEval: 'clipboard clear'. (ClipStatus isKindOf: Boolean) ifTrue: [ ClipStatus := aString. ^self ]. aString isNil ifTrue: [ ClipStatus := false. ^self ]. self tclEval: 'clipboard append ', aString asTkString. ClipStatus := true ! createColor: cyan magenta: magenta yellow: yellow "Answer a color that can be passed to methods such as `backgroundColor:'. The color will have the given CMY components (range is 0~65535)." ^self createColor: 65535 - cyan green: 65535 - magenta blue: 65535 - yellow ! createColor: cyan magenta: magenta yellow: yellow black: black "Answer a color that can be passed to methods such as `backgroundColor:'. The color will have the given CMYK components (range is 0~65535)." | base | base := 65535 - black. ^self createColor: (base - cyan max: 0) green: (base - magenta max: 0) blue: (base - yellow max: 0) ! createColor: hue saturation: sat value: value "Answer a color that can be passed to methods such as `backgroundColor:'. The color will have the given HSV components (range is 0~65535)." | hue6 f val index components | hue6 := (hue \\ 1) * 6. index := hue6 truncated + 1. "Which of the six slices of the hue circle" f := hue6 fractionPart. "Where in the slice of the hue circle" val := 65535 * value. components := Array with: val "v" with: val * (1 - sat) "p" with: val * (1 - (sat * f)) "q" with: val * (1 - (sat * (1 - f))). "t" ^self createColor: (components at: (#(1 3 2 2 4 1) at: index)) floor green: (components at: (#(4 1 1 3 2 2) at: index)) floor blue: (components at: (#(2 2 4 1 1 3) at: index)) floor ! createColor: red green: green blue: blue "Answer a color that can be passed to methods such as `backgroundColor:'. The color will have the given RGB components (range is 0~65535)." "The answer is actually a String with an X color name, like '#FFFFC000C000' for pink" ^(String new: 13) at: 1 put: $#; at: 2 put: (Character digitValue: ((red bitShift: -12) bitAnd: 15)); at: 3 put: (Character digitValue: ((red bitShift: -8) bitAnd: 15)); at: 4 put: (Character digitValue: ((red bitShift: -4) bitAnd: 15)); at: 5 put: (Character digitValue: ( red bitAnd: 15)); at: 6 put: (Character digitValue: ((green bitShift: -12) bitAnd: 15)); at: 7 put: (Character digitValue: ((green bitShift: -8) bitAnd: 15)); at: 8 put: (Character digitValue: ((green bitShift: -4) bitAnd: 15)); at: 9 put: (Character digitValue: ( green bitAnd: 15)); at: 10 put: (Character digitValue: ((blue bitShift: -12) bitAnd: 15)); at: 11 put: (Character digitValue: ((blue bitShift: -8) bitAnd: 15)); at: 12 put: (Character digitValue: ((blue bitShift: -4) bitAnd: 15)); at: 13 put: (Character digitValue: ( blue bitAnd: 15)); yourself ! fonts "Answer the names of the font families in the system. Additionally, `Times', `Courier' and `Helvetica' are always made available." | stream result font ch | self tclEval: 'lsort [font families]'. stream := ReadStream on: self tclResult. result := WriteStream on: (Array new: stream size // 10). [ stream atEnd ] whileFalse: [ (ch := stream next) isSeparator ifFalse: [ ch = ${ ifTrue: [ font := stream upTo: $} ] ifFalse: [ font := ch asString, (stream upTo: $ ) ]. result nextPut: font. ] ]. ^result contents ! platform "Answer the platform on which Blox is running; it can be either #unix, #macintosh or #windows." Platform isNil ifTrue: [ self tclEval: 'return $tcl_platform(platform)'. Platform := self tclResult asSymbol ]. ^Platform ! active "Answer the currently active Blox, or nil if the focus does not belong to a Smalltalk window." self tclEval: 'focus'. ^self fromString: self tclResult ! at: aPoint "Answer the Blox containing the given point on the screen, or nil if no Blox contains the given point (either because no Smalltalk window is there or because it is covered by another window)." self tclEval: 'winfo containing %1 %2' with: aPoint x printString with: aPoint y printString. ^self fromString: self tclResult ! atMouse "Answer the Blox under the mouse cursor's hot spot, or nil if no Blox contains the given point (either because no Smalltalk window is there or because it is covered by another window)." self tclEval: 'eval winfo containing [winfo pointerxy .]'. ^self fromString: self tclResult ! mousePointer "If the mouse pointer is on the same screen as the application's windows, returns a Point containing the pointer's x and y coordinates measured in pixels in the screen's root window (under X, if a virtual root window is in use on the screen, the position is computed in the whole desktop, not relative to the top-left corner of the currently shown portion). If the mouse pointer isn't on the same screen as window then answer nil." | stream x | self tclEval: 'winfo pointerxy .'. stream := ReadStream on: self tclResult. (stream peekFor: $-) ifTrue: [ ^nil ]. x := (stream upTo: $ ) asInteger. ^x @ stream upToEnd asInteger ! screenResolution "Answer a Point containing the resolution in dots per inch of the screen, in the x and y directions." | stream x | self tclEval: 'return " [expr [winfo screenwidth .] * 25.4 / [winfo screenmmwidth .]] [expr [winfo screenheight .] * 25.4 / [winfo screenmmheight .]]" '. stream := ReadStream on: self tclResult. x := (stream upTo: $ ) asNumber rounded. ^x @ stream upToEnd asNumber rounded ! screenOrigin "Answer a Point indicating the coordinates of the upper left point of the screen in the virtual root window on which the application's windows are drawn (under Windows and the Macintosh, that's always 0 @ 0)" | stream x | self tclEval: 'return "[winfo vrootx .] [winfo vrooty .]"'. stream := ReadStream on: self tclResult. x := (stream upTo: $ ) asInteger negated. ^x @ stream upToEnd asInteger negated ! screenSize "Answer a Point containing the size of the virtual root window on which the application's windows are drawn (under Windows and the Macintosh, that's the size of the screen)" | stream x | self tclEval: 'return "[winfo vrootwidth .] [winfo vrootheight .]"'. stream := ReadStream on: self tclResult. x := (stream upTo: $ ) asInteger. ^x @ stream upToEnd asInteger ! ! !Blox class methodsFor: 'private'! fromString: aString "Convert from Tk widget path name to Blox object. Answer nil if it isn't possible." | first last oopString oopInteger | last := aString size. aString size to: 1 by: -1 do: [ :i | (aString at: i) = $. ifTrue: [ last := i - 1 ]. (aString at: i) = $w ifTrue: [ oopString := aString copyFrom: i + 1 to: last. oopInteger := 0. oopInteger := oopString inject: 0 into: [ :val :ch | val * 36 + ch digitValue ]. ^oopInteger asObjectNoFail ] ]. ^nil ! ! !Blox methodsFor: 'basic'! deepCopy "It does not make sense to make a copy, because it would make data inconsistent across different objects; so answer the receiver" ^self ! shallowCopy "It does not make sense to make a copy, because it would make data inconsistent across different objects; so answer the receiver" ^self ! release "Destroy the receiver if it still exists, then perform the usual task of removing the dependency links" primitive isNil ifFalse: [ self destroy ]. super release. ! ! !Blox methodsFor: 'widget protocol'! asPrimitiveWidget "Answer the primitive widget that implements the receiver." self subclassResponsibility ! boundingBox "Answer a Rectangle containing the bounding box of the receiver" ^(self x @ self y) extent: (self width @ self height) ! boundingBox: rect "Set the bounding box of the receiver to rect (a Rectangle)." self left: rect left top: rect top right: rect right bottom: rect bottom ! childrenDo: aBlock "Evaluate aBlock once for each of the receiver's child widgets, passing the widget to aBlock as a parameter" children do: aBlock ! childrenCount "Answer how many children the receiver has" ^children size ! destroy "Destroy the receiver" self tclEval: 'destroy ', self container ! fontWidth: aString "Answer the width of aString in pixels, when displayed in the same font as the receiver. Although defined here, this method is only used for widgets that define a #font method" self tclEval: 'font measure %1 %2' with: self font asTkString with: aString asTkString. ^self tclResult asNumber ! fontHeight: aString "Answer the height of aString in pixels, when displayed in the same font as the receiver. Although defined here, this method is only used for widgets that define a #font method" self tclEval: 'font metrics %1 -linespace' with: self font asTkString. ^((aString occurrencesOf: Character nl) + 1) * self tclResult asNumber ! enabled "Answer whether the receiver is enabled to input. Although defined here, this method is only used for widgets that define a #state method" ^self state ~= #disabled ! enabled: enabled "Set whether the receiver is enabled to input (enabled is a boolean). Although defined here, this method is only used for widgets that define a #state: method" self state: (enabled ifTrue: [ #normal ] ifFalse: [ #disabled ]) ! exists "Answer whether the receiver has been destroyed or not (answer false in the former case, true in the latter)." ^primitive notNil ! drawingArea "Answer a Rectangle identifying the receiver's drawing area. The rectangle's corners specify the upper-left and lower-right corners of the client area. Because coordinates are relative to the upper-left corner of a window's drawing area, the coordinates of the rectangle's corner are (0,0). " ^(0 @ 0) corner: (self widthAbsolute @ self heightAbsolute) ! extent "Answer a Point containing the receiver's size" ^(self width @ self height) ! extent: extent "Set the receiver's size to the width and height contained in extent (a Point)." self width: extent x height: extent y ! isWindow "Answer whether the receiver represents a window on the screen." ^false ! left: left top: top right: right bottom: bottom "Set the bounding box of the receiver through its components." self x: left y: top width: right - left + 1 height: bottom - top + 1 ! parent "Answer the receiver's parent (or nil for a top-level window)." ^parent ! pos: position "Set the receiver's origin to the width and height contained in position (a Point)." self x: position x y: position y ! posVert: aBlox "Position the receiver just below aBlox." self x: aBlox x y: aBlox y + aBlox height ! posHoriz: aBlox "Position the receiver immediately to the right of aBlox." self x: aBlox x + aBlox width y: aBlox y ! toplevel "Answer the top-level object (typically a BWindow or BPopupWindow) connected to the receiver." self parent isNil ifTrue: [ ^self ]. ^self parent toplevel ! window "Answer the window in which the receiver stays. Note that while #toplevel won't answer a BTransientWindow, this method will." ^self parent window ! width: xSize height: ySize "Set the size of the receiver through its components xSize and ySize." self width: xSize; height: ySize ! withChildrenDo: aBlock "Evaluate aBlock passing the receiver, and then once for each of the receiver's child widgets." self value: aBlock. self childrenDo: aBlock ! x: xPos y: yPos "Set the origin of the receiver through its components xPos and yPos." self x: xPos; y: yPos ! x: xPos y: yPos width: xSize height: ySize "Set the bounding box of the receiver through its origin and size." self x: xPos y: yPos; width: xSize height: ySize ! ! !Blox methodsFor: 'creating children'! make: array "Create children of the receiver. Answer a Dictionary of the children. Each element of array is an Array with the form: - first element = name, becomes the Dictionary's key - second element = class name symbol - third element = parameter setting array, for example #(width: 50 height: 30 backgroundColor: 'blue') - from the fourth element = children of the widget; each element has the same format described here" ^self make: array on: LookupTable new ! make: array on: result "Private - Create children of the receiver, adding them to result; answer result. array has the format described in the comment to #make:" array do: [ :each | self makeChild: each on: result ]. ^result ! makeChild: each on: result "Private - Create a child of the receiver, adding them to result; each is a single element of the array described in the comment to #make:" | current selector | current := result at: (each at: 1) put: ((Smalltalk classAt: (each at: 2)) new: self). each at: 3 do: [ :param | selector isNil ifTrue: [ selector := param ] ifFalse: [ current perform: selector with: param. selector := nil ] ]. each size > 3 ifFalse: [ ^result ]. each from: 4 to: each size do: [ :child | current makeChild: child on: result ]. ! ! !Blox methodsFor: 'customization'! addChild: child "The widget identified by child has been added to the receiver. This method is public not because you can call it, but because it can be useful to override it, not forgetting the call to either the superclass implementation or #basicAddChild:, to perform some initialization on the children just added. Answer the new child." ^children addLast: child ! basicAddChild: child "The widget identified by child has been added to the receiver. Add it to the children collection and answer the new child. This method is public because you can call it from #addChild:." ^children addLast: child ! ! !Blox methodsFor: 'private'! primBind: event to: aSymbol of: anObject parameters: params "Private - Register the given event, to be passed to anObject via the aSymbol selector with the given parameters" ^self bind: event to: aSymbol of: anObject parameters: params prefix: 'bind ', self connected ! bind: event to: aSymbol of: anObject parameters: params prefix: prefix "Private - Low level event binding - execute a Tcl command like ` {+callback }'. Prefix is typically some kind of the Tcl `bind' command." | stream | stream := WriteStream with: prefix copy. stream space; nextPutAll: event; nextPutAll: ' {+callback '; print: anObject asOop; space; nextPutAll: aSymbol asTkString; space; nextPutAll: params; nextPut: $}. self tclEval: stream contents. ^event ! properties "Private - Answer the properties dictionary" ^properties ! container "Private - Answer the name of Tk widget for the container widget. This widget is used when handling geometry and by a few methods such as #effect and #borderWidth." ^self asPrimitiveWidget container ! connected "Private - Answer the name of Tk widget for the connected widget. This widget is used for most options and for event binding." ^self asPrimitiveWidget connected ! initialize: parentWidget "This is called by #new: to initialize the widget (as the name says...). The default implementation initializes the receiver's instance variables. This method is public not because you can call it, but because it might be useful to override it. Always answer the receiver." parent := parentWidget. properties := IdentityDictionary new. children := OrderedCollection new. ! guiObject "Private - Left for backward compatibility; answer the `primitive' instance variable which can either be another widget or it can be related to the names returned by #connected and #container." ^primitive ! primitive "Private - Answer the `primitive' instance variable which can either be another widget or it can be related to the names returned by #connected and #container." ^primitive ! destroyed "Private - The receiver has been destroyed, clear the instance variables to release some memory." children := primitive := parent := nil ! ! Blox "#normal, #disabled, sometimes #active." defineMutator: 'state' command: '%1 configure -state %3' key: 'state' toStringCode: ''; defineAccessor: 'state' command: '%1 cget -state' key: 'state' fromStringCode: 'asSymbol'! "------------------- Generic UI elements -------------------------" Blox subclass: #BWidget instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BWidget comment: ' I am the superclass for every widget except those related to menus. I provide more common methods and geometry management'! !BWidget class methodsFor: 'popups'! new "Create an instance of the receiver inside a BPopupWindow; do not map the window, answer the new widget. The created widget will become a child of the window and be completely attached to it (e.g. the geometry methods will modify the window's geometry). Note that while the widget *seems* to be directly painted on the root window, it actually belongs to the BPopupWindow; so don't send #destroy to the widget to remove it, but rather to the window." ^self new: BPopupWindow new ! popup: initializationBlock "Create an instance of the receiver inside a BPopupWindow; before returning, pass the widget to the supplied initializationBlock, then map the window. Answer the new widget. The created widget will become a child of the window and be completely attached to it (e.g. the geometry methods will modify the window's geometry). Note that while the widget *seems* to be directly painted on the root window, it actually belongs to the BPopupWindow; so don't send #destroy to the widget to remove it, but rather to the window." | widget window | window := BPopupWindow new. widget := self new: window. initializationBlock value: widget. window map. ^widget ! !BWidget class methodsFor: 'creating Tk interface methods'! defineFontProtocol "e.g. 'Helvetica 18 bold' or '{Zapf Chancery} 14' (braces are mandatory if the font family is made of two or more words." self defineAccessor: 'font' option: 'font' fromStringCode: ''; defineMutator: 'font' option: 'font' toStringCode: '' ! defineGeometryMethods: keyword relativeTo: parentSelector | s | #( '%1Absolute "Force a recalculation of the layout of widgets in the receiver''s parent, then answer the current %1 of the receiver in pixels." Blox idle. self tclEval: ''winfo %1 '', self container. ^self tclResult asInteger' '%1 "Answer the `variable'' part of the receiver''s %1 within the parent widget. The value returned does not include any fixed amount of pixels indicated by #%1Offset: and must be interpreted in a relative fashion: the ratio of the returned value to the current size of the parent will be preserved upon resize. This apparently complicated method is known as `rubber sheet'' geometry management." ^self parent %1Child: self.' '%1: value "Set to `value'' the %1 of the widget within the parent widget. The value is specified in a relative fashion as an integer, so that the ratio of `value'' to the current size of the parent will be preserved upon resize. This apparently complicated method is known as `rubber sheet'' geometry management." self parent child: self %1: value.' '%1Offset: value "Add or subtract to the %1 of the receiver a fixed amount of `value'' pixels, with respect to the value set in a relative fashion through the #%1: method." self parent child: self %1Offset: value.' '%1Pixels: value "Set the current %1 of the receiver to `value'' pixels. Note that, after calling this method, #%1 will answer 0, which is logical considering that there is no `variable'' part of the size (refer to #%1 and #%1: for more explanations)." self %1: 0; %1Offset: value' '%1Child: child "Answer the given child''s %1. The default implementation of this method uses `rubber-sheet'' geometry management as explained in the comment to BWidget''s #%1 method. You should not use this method, which is automatically called by the child''s #%1 method, but you might want to override. The child''s property slots whose name ends with `Geom'' are reserved for this method. This method should never fail -- if it doesn''t apply to the kind of geometry management that the receiver does, just return 0." ^(child properties at: #%1Geom ifAbsentPut: [0]) * self %2' 'child: child %1: value "Set the given child''s %1 to value. The default implementation of this method uses `rubber-sheet'' geometry management as explained in the comment to BWidget''s #%1 method. You should not use this method, which is automatically called by the child''s #%1: method, but you might want to override it. The child''s property slots whose name ends with `Geom'' are reserved for this method. This method should never fail -- if it doesn''t apply to the kind of geometry management that the receiver does, just do nothing." | relative %2Parent | %2Parent := self %2. %2Parent = 0 ifTrue: [ ^self ]. child properties at: #%1Geom put: (relative := value / %2Parent). self tclEval: ''place '', child container, '' -rel%1 '', relative asFloat printString' 'child: child %1Offset: value "Adjust the given child''s %1 by a fixed amount of value pixel. This is meaningful for the default implementation, using `rubber-sheet'' geometry management as explained in the comment to BWidget''s #%1 and #%1Offset: methods. You should not use this method, which is automatically called by the child''s #%1Offset: method, but you might want to override it. if it doesn''t apply to the kind of geometry management that the receiver does, just add value to the current %1 of the widget." self tclEval: ''place '', child container, '' -%1 '', value asFloat printString' ) do: [ :code | self compile: (code bindWith: keyword with: parentSelector) classified: 'geometry management' ] ! ! BWidget defineGeometryMethods: 'width' relativeTo: 'width'; defineGeometryMethods: 'height' relativeTo: 'height'; defineGeometryMethods: 'x' relativeTo: 'width'; defineGeometryMethods: 'y' relativeTo: 'height'; defineAccessor: 'tabStop' option: 'takefocus' fromStringCode: '== ''1'''; defineMutator: 'tabStop' option: 'takefocus' toStringCode: 'asCBooleanValue printString'; "e.g. hand2 or left_ptr" defineAccessor: 'cursor' option: 'cursor' fromStringCode: 'asSymbol'; defineMutator: 'cursor' option: 'cursor' toStringCode: ''; "#raised, #sunken, #flat, #ridge, #solid, #groove. #solid means 2-D. #groove means 3-D, with only the border sunken. #ridge means 3-D, with only the border raised. Note: these work on the container, not on the connected object! !" defineMutator: 'effect' command: '%2 configure -relief %3' key: 'effect' toStringCode: ''; defineAccessor: 'effect' command: '%2 cget -relief' key: 'effect' fromStringCode: 'asSymbol'; defineMutator: 'borderWidth' command: '%2 configure -borderwidth %3' key: 'border' toStringCode: 'printString'; defineAccessor: 'borderWidth' command: '%2 cget -borderwidth' key: 'border' fromStringCode: 'asInteger' ! !BWidget methodsFor: 'geometry management'! xRoot "Answer the x position of the receiver with respect to the top-left corner of the desktop (including the offset of the virtual root window under X)." self tclEval: 'expr [winfo rootx %1] + [winfo vrootx %1]' with: self container. ^self tclResult asInteger ! yRoot "Answer the y position of the receiver with respect to the top-left corner of the desktop (including the offset of the virtual root window under X)." self tclEval: 'expr [winfo rooty %1] + [winfo vrooty %1]' with: self container. ^self tclResult asInteger ! ! !BWidget methodsFor: 'widget protocol'! activate "At any given time, one window on each display is designated as the focus window; any key press or key release events for the display are sent to that window. This method allows one to choose which window will have the focus in the receiver's display If the application currently has the input focus on the receiver's display, this method resets the input focus for the receiver's display to the receiver. If the application doesn't currently have the input focus on the receiver's display, Blox will remember the receiver as the focus for its top-level; the next time the focus arrives at the top-level, it will be redirected to the receiver (this is because most window managers will set the focus only to top-level windows, leaving it up to the application to redirect the focus among the children of the top-level)." self tclEval: 'focus ', self connected ! activatePrevious "Activate the previous widget in the focus `tabbing' order. The focus order depends on the widget creation order; you can set which widgets are in the order with the #tabStop: method." self tclEval: 'focus [ tk_focusPrev %1 ]' with: self connected ! activateNext "Activate the next widget in the focus `tabbing' order. The focus order depends on the widget creation order; you can set which widgets are in the order with the #tabStop: method." self tclEval: 'focus [ tk_focusNext %1 ]' with: self connected ! bringToTop "Raise the receiver so that it is above all of its siblings in the widgets' z-order; the receiver will not be obscured by any siblings and will obscure any siblings that overlap it." self tclEval: 'raise ', self container ! isActive "Return whether the receiver is the window that currently owns the focus on its display." self tclEval: 'focus'. ^self tclResult = self connected ! sendToBack "Lower the receiver so that it is below all of its siblings in the widgets' z-order; the receiver will be obscured by any siblings that overlap it and will not obscure any siblings." self tclEval: 'lower ', self container ! ! !BWidget methodsFor: 'customization'! addChild: child "The widget identified by child has been added to the receiver. This method is public not because you can call it, but because it can be useful to override it, not forgetting the call to basicAddChild, to perform some initialization on the children just added. Answer the new child." child isWindow ifFalse: [ self tclEval: 'place %1 -in %2' with: child container with: self container ]. ^self basicAddChild: child ! create "Make the receiver able to respond to its widget protocol. This method is public not because you can call it, but because it can be useful to override it, not forgetting the call to super, to perform some initialization on the primitive widget just created; for an example of this, see the implementation of BButtonLike." self subclassResponsibility ! setInitialSize "This is called by #initialize: to set the widget's initial size. The whole area is occupied by default. This method is public not because you can call it, but because it can be useful to override it, not forgetting to call *all* of #x:, #y:, #width: and #height:." "Make the Tk placer's status, the receiver's properties and the window status (as returned by winfo) consistent." self x: 0 y: 0 width: self parent width height: self parent height ! initialize: parentWidget "This is called by #new: to initialize the widget (as the name says...). The default implementation calls all the other methods in the `customization' protocol and some private ones that take care of making the receiver's status consistent, so you should usually call it instead of doing everything by hand. This method is public not because you can call it, but because it might be useful to override it. Always answer the receiver." super initialize: parentWidget. self create. self bind: '' to: #destroyed of: self parameters: ''. self setInitialSize. self parent notNil ifTrue: [ self parent addChild: self ]. ! ! "------------------- Primitives --------------------------------------" BWidget subclass: #BPrimitive instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BPrimitive comment: ' I am the superclass for every widget (except menus) directly provided by the underlying GUI system.'! !BPrimitive methodsFor: 'accessing'! asPrimitiveWidget "Answer the primitive widget that implements the receiver." ^self ! ! !BPrimitive methodsFor: 'private'! container "Private - Answer the name of Tk widget for the container widget." ^primitive ! connected "Private - Answer the name of Tk widget for the connected widget." ^primitive ! create "Private - Make the receiver able to respond to its widget protocol." self create: '' ! create: options "Private - Make the receiver able to respond to its widget protocol, initializing the Tk widget with the options passed in the parameter." self tclEval: '%1 %2 %3' with: self widgetType with: self connected with: options. ! initialize: parentWidget "Private - This is called by #new: to initialize the widget (as the name says...). This implementation creates a unique Tk path name for the widget, then calls the superclass implementation." primitive := self setWidgetName: parentWidget. super initialize: parentWidget. ! setWidgetName: parentWidget "Private - Create and answer a unique Tk path name for the widget" | name | name := '.w', (self asOop printString: 36). ^parentWidget isNil ifTrue: [ name ] ifFalse: [ parentWidget container, name ]. ! widgetType "Private - Answer the Tk command to create the widget" self subclassResponsibility ! ! "------------------------------ vs. extended -------------------------" BWidget subclass: #BExtended instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BExtended comment: ' Just like Gui, I serve as a base for complex objects which expose an individual protocol but internally use a Blox widget for creating their user interface. Unlike Gui, however, the instances of my subclasses understand the standard widget protocol. Just override my newPrimitive method to return another widget, and you''ll get a class which interacts with the user like that widget (a list box, a text box, or even a label) but exposes a different protocol.'! !BExtended methodsFor: 'accessing'! asPrimitiveWidget "Answer the primitive widget that implements the receiver." ^primitive asPrimitiveWidget ! ! !BExtended methodsFor: 'customization'! newPrimitive "Create and answer a new widget on which the implementation of the receiver will be based. You should not call this method directly; instead you must override it in BExtended's subclasses." self subclassResponsibility ! create "After this method is called (the call is made automatically) the receiver will be attached to a `primitive' widget (which can be in turn another extended widget). This method is public not because you can call it, but because it can be useful to override it, not forgetting the call to super (which only calls #newPrimitive and saves the result), to perform some initialization on the primitive widget just created; overriding #create is in fact more generic than overriding #newPrimitive. For an example of this, see the implementation of BButtonLike." primitive := self newPrimitive ! ! "------------------------------ Viewport controls --------------------------" BPrimitive subclass: #BViewport instanceVariableNames: 'connected' classVariableNames: 'InitializedVP' poolDictionaries: '' category: 'Graphics-Windows' ! BViewport comment: ' I represent an interface which is common to widgets that can be scrolled, like list boxes or text widgets.'! !BViewport class methodsFor: 'initialization'! initializeOnStartup InitializedVP := false ! !BViewport methodsFor: 'accessing'! connected "Private - Answer the name of Tk widget for the connected widget." ^connected ! ! !BViewport methodsFor: 'private'! create: options "Private - Create an instance of the receiver which sports two beautiful scrollbars, in the same way as BPrimitive's implementation of #create:." InitializedVP ifFalse: [ self defineViewportProcedures ]. self tclEval: 'createViewport %1 %2 {%3}' with: self widgetType with: self container with: options. connected := self tclResult. ! defineViewportProcedures InitializedVP := true. self tclEval: ' ## Procedures that handle automatic show/hide of scrollbars ## set horizSB {-row 1 -column 0 -sticky ew} set vertSB {-row 0 -column 1 -sticky ns} proc scrollbarSet {w gridArgs first last} { if { $first == 0 && $last == 1 } { grid forget $w } else { eval grid $w $gridArgs } $w set $first $last } proc createViewport {type cnt opt} { frame $cnt -relief sunken eval $type $cnt.ctl $opt scrollbar $cnt.hs -orient horiz -command "$cnt.ctl xview" scrollbar $cnt.vs -orient vert -command "$cnt.ctl yview" grid $cnt.ctl -column 0 -row 0 -sticky news grid propagate $cnt off grid rowconfigure $cnt 0 -minsize 1 -weight 1 grid rowconfigure $cnt 1 -weight 0 grid columnconfigure $cnt 0 -minsize 1 -weight 1 grid columnconfigure $cnt 1 -weight 0 return $cnt.ctl }' ! ! !BViewport methodsFor: 'scrollbars'! horizontal ^self properties at: #horizontal ifAbsent: [ false ] ! horizontalNeeded self tclEval: 'expr [lindex [%1 xview] 0] > 0 || [lindex [%1 xview] 1] < 1' with: self connected. ^self tclResult = '1' ! horizontalShown ^self horizontal and: [ self horizontalNeeded ] ! horizontal: aBoolean | code | (self properties at: #horizontal ifAbsent: [ false ]) == aBoolean ifTrue: [ ^self ]. code := (self properties at: #horizontal put: aBoolean) ifTrue: [ '%1.ctl configure -xscrollcommand "scrollbarSet %1.hs {$horizSB}" eval scrollbarSet %1.hs {$horizSB} [%1.ctl xview]' ] ifFalse: [ '%1.ctl configure -xscrollcommand "concat" # do nothing eval scrollbarSet %1.hs {$horizSB} 0 1' ]. self tclEval: code with: self container ! vertical ^self properties at: #vertical ifAbsent: [ false ] ! verticalNeeded self tclEval: 'expr [lindex [%1 yview] 0] > 0 || [lindex [%1 yview] 1] < 1' with: self connected. ^self tclResult = '1' ! verticalShown ^self vertical and: [ self verticalNeeded ] ! vertical: aBoolean | code | (self properties at: #vertical ifAbsent: [ false ]) == aBoolean ifTrue: [ ^self ]. code := (self properties at: #horizontal put: aBoolean) ifTrue: [ '%1.ctl configure -yscrollcommand "scrollbarSet %1.vs {$vertSB}" eval scrollbarSet %1.vs {$vertSB} [%1.ctl yview]' ] ifFalse: [ '%1.ctl configure -yscrollcommand "concat" # do nothing eval scrollbarSet %1.vs {$vertSB} 0 1' ]. self tclEval: code with: self container ! ! "------------------------------ Menu superclass -----------------------" Blox subclass: #BMenuObject instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Windows' ! BMenuObject comment: ' I am an abstract superclass for widgets which make up a menu structure.'! "Define position methods as dummy" #('x' 'x: value' 'y' 'y: value' 'width' 'width: value' 'height' 'height: value') do: [ :each | BMenuObject compile: each, ' "This method is deprecated and will disappear in a future version."' classified: 'disabled methods' ]! BMenuObject defineColorProtocolWithActivePrefix: 'active' tk: 'active'! !BMenuObject methodsFor: 'accessing'! asPrimitiveWidget "Answer the primitive widget that implements the receiver." ^self ! ! "----------------------------------- ADDS TO THE STANDARD IMAGE ----------" !String methodsFor: 'private - Tk interface'! asTkString "Private, Blox - Answer a copy of the receiver enclosed in double-quotes and in which all the characters that Tk cannot read are escaped through a backslash" | i stream ch crFound | stream := WriteStream on: (self copyEmpty: self size + 10). stream nextPut: $". crFound := false. i := 1. [ i <= self size ] whileTrue: [ ch := self at: i. ch = $" ifTrue: [ stream nextPut: $\ ]. ch = $\ ifTrue: [ stream nextPut: $\ ]. ch = $[ ifTrue: [ stream nextPut: $\ ]. ch = $] ifTrue: [ stream nextPut: $\ ]. ch = $$ ifTrue: [ stream nextPut: $\ ]. ch = Character nl ifTrue: [ "Under Windows, CR/LF-separated lines are common. Turn a CR/LF pair into a single \n" crFound ifTrue: [ stream skip: -2 ]. stream nextPut: $\. ch := $n ]. "On Macs, CR-separated lines are common. Turn 'em into \n" (crFound := (ch == Character cr)) ifTrue: [ stream nextPut: $\. ch := $n ]. (ch < $ ) | (ch > $~) ifFalse: [ stream nextPut: ch ] ifTrue: [ stream nextPutAll: '\'; nextPut: (Character value: ch value // 64 \\ 8 + 48); nextPut: (Character value: ch value // 8 \\ 8 + 48); nextPut: (Character value: ch value \\ 8 + 48) ]. i := i + 1 ]. stream nextPut: $". ^stream contents ! asTkImageString "Private, Blox - Look for GIF images; for those, since Base-64 data does not contain { and }, is better to use the {} syntax." "R0lG is `GIF' in Base-64 encoding." ^(self match: 'R0lG*') ifTrue: [ '{%1}' bindWith: self ] ifFalse: [ self asTkString ] ! !