Squeak-dev August 2009

squeak-dev@lists.squeakfoundation.org

114 participants
300 discussions

The Trunk: Monticello-ar.321.mcz
by commits＠source.squeak.org 31 Aug '09

31 Aug '09

Andreas Raab uploaded a new version of Monticello to project The Trunk: http://source.squeak.org/trunk/Monticello-ar.321.mcz ==================== Summary ==================== Name: Monticello-ar.321 Author: ar Time: 30 August 2009, 8:35:22 am UUID: dedee780-04ae-e84a-8e6c-0947f7a24780 Ancestors: Monticello-tfel.320 Adds a workaround for the broken 'atomic' loading behavior in MCPackageLoader>>basicLoad. =============== Diff against Monticello-tfel.320 =============== Item was changed: ----- Method: MCPackageLoader>>basicLoad (in category 'private') ----- basicLoad errorDefinitions := OrderedCollection new. + [[ + + "FIXME. Do a separate pass on loading class definitions as the very first thing. + This is a workaround for a problem with the so-called 'atomic' loading (you wish!!) + which isn't atomic at all but mixes compilation of methods with reshapes of classes. + + Since the method is not installed until later, any class reshape in the middle *will* + affect methods in subclasses that have been compiled before. There is probably + a better way of dealing with this by ensuring that the sort order of the definition lists + superclass definitions before methods for subclasses but I need this NOW, and adding + an extra pass ensures that methods are compiled against their new class definitions." + + additions do: [:ea | self loadClassDefinition: ea] displayingProgress: 'Loading classes...'. + + additions do: [:ea | self tryToLoad: ea] displayingProgress: 'Compiling methods...'. - [[additions do: [:ea | self tryToLoad: ea] displayingProgress: 'Loading...'. removals do: [:ea | ea unload] displayingProgress: 'Cleaning up...'. self shouldWarnAboutErrors ifTrue: [self warnAboutErrors]. errorDefinitions do: [:ea | ea addMethodAdditionTo: methodAdditions] displayingProgress: 'Reloading...'. methodAdditions do: [:each | each installMethod]. methodAdditions do: [:each | each notifyObservers]. additions do: [:ea | ea postloadOver: (self obsoletionFor: ea)] displayingProgress: 'Initializing...'] on: InMidstOfFileinNotification do: [:n | n resume: true]] ensure: [self flushChangesFile]! Item was added: + ----- Method: MCPackageLoader>>loadClassDefinition: (in category 'private') ----- + loadClassDefinition: aDefinition + [aDefinition isClassDefinition ifTrue:[aDefinition load]] on: Error do: [errorDefinitions add: aDefinition].!

1 0

The Trunk: ToolBuilder-Morphic-ar.35.mcz
by commits＠source.squeak.org 31 Aug '09

31 Aug '09

Andreas Raab uploaded a new version of ToolBuilder-Morphic to project The Trunk: http://source.squeak.org/trunk/ToolBuilder-Morphic-ar.35.mcz ==================== Summary ==================== Name: ToolBuilder-Morphic-ar.35 Author: ar Time: 30 August 2009, 5:28:43 am UUID: 0d095223-7722-7b4f-a18b-1e2ef334b6da Ancestors: ToolBuilder-Morphic-ar.34 Implement font-chooser interface for Morphic. =============== Diff against ToolBuilder-Morphic-ar.34 =============== Item was added: + ----- Method: MorphicUIManager>>chooseFont:for:setSelector:getSelector: (in category 'ui requests') ----- + chooseFont: titleString for: aModel setSelector: setSelector getSelector: getSelector + "Open a font-chooser for the given model" + ^FontChooserTool default + openWithWindowTitle: titleString + for: aModel + setSelector: setSelector + getSelector: getSelector!

1 0

The Trunk: ToolBuilder-MVC-ar.15.mcz
by commits＠source.squeak.org 31 Aug '09

31 Aug '09

Andreas Raab uploaded a new version of ToolBuilder-MVC to project The Trunk: http://source.squeak.org/trunk/ToolBuilder-MVC-ar.15.mcz ==================== Summary ==================== Name: ToolBuilder-MVC-ar.15 Author: ar Time: 30 August 2009, 5:28:07 am UUID: 26f9ab5c-5cb3-424e-ae1f-81bbb7c57af6 Ancestors: ToolBuilder-MVC-bp.14 Implement font-chooser interface for MVC. =============== Diff against ToolBuilder-MVC-bp.14 =============== Item was added: + ----- Method: MVCUIManager>>chooseFont:for:setSelector:getSelector: (in category 'ui requests') ----- + chooseFont: titleString for: aModel setSelector: setSelector getSelector: getSelector + "Open a font-chooser for the given model" + ^TextStyle mvcPromptForFont: titleString andSendTo: aModel withSelector: setSelector!

1 0

The Trunk: ToolBuilder-Kernel-ar.20.mcz
by commits＠source.squeak.org 31 Aug '09

31 Aug '09

Andreas Raab uploaded a new version of ToolBuilder-Kernel to project The Trunk: http://source.squeak.org/trunk/ToolBuilder-Kernel-ar.20.mcz ==================== Summary ==================== Name: ToolBuilder-Kernel-ar.20 Author: ar Time: 30 August 2009, 5:27:11 am UUID: e874090d-db4c-d34e-ac06-a760b7466c8d Ancestors: ToolBuilder-Kernel-ar.19 Add UIManager support for a font-chooser dialog, based on the FreeTypePlus FontChooser interface. =============== Diff against ToolBuilder-Kernel-ar.19 =============== Item was added: + ----- Method: UIManager>>chooseFont:for:setSelector:getSelector: (in category 'ui requests') ----- + chooseFont: titleString for: aModel setSelector: setSelector getSelector: getSelector + "Open a font-chooser for the given model"!

1 0

The Trunk: System-ar.139.mcz
by commits＠source.squeak.org 31 Aug '09

31 Aug '09

Andreas Raab uploaded a new version of System to project The Trunk: http://source.squeak.org/trunk/System-ar.139.mcz ==================== Summary ==================== Name: System-ar.139 Author: ar Time: 30 August 2009, 5:24:53 am UUID: 389aa44d-05bd-c84f-9dd3-96cfcfc9c62b Ancestors: System-dtl.138 FreeTypePlus integration. Vector the preference requests for changing standard fonts through UI manager so that we can fire off a proper chooser dialog. =============== Diff against System-dtl.138 =============== Item was changed: ----- Method: Preferences class>>chooseSystemFont (in category 'fonts') ----- chooseSystemFont + self + chooseFontWithPrompt: 'Default font...' translated + andSendTo: self + withSelector: #setSystemFontTo: + highlightSelector: #standardSystemFont! - self chooseFontWithPrompt: 'Choose the default text font' translated andSendTo: self withSelector: #setSystemFontTo: highlight: (TextConstants at: #DefaultTextStyle) defaultFont! Item was added: + ----- Method: Preferences class>>chooseFontWithPrompt:andSendTo:withSelector:highlightSelector: (in category 'fonts') ----- + chooseFontWithPrompt: aPrompt andSendTo: aReceiver withSelector: aSelector highlightSelector: highlightSelector + ^UIManager default + chooseFont: aPrompt + for: aReceiver + setSelector: aSelector + getSelector: highlightSelector ! Item was added: Item was changed: ----- Method: Preferences class>>chooseFlapsFont (in category 'fonts') ----- chooseFlapsFont + self + chooseFontWithPrompt: 'Flaps font...' translated + andSendTo: self + withSelector: #setFlapsFontTo: + highlightSelector: #standardFlapFont! - self chooseFontWithPrompt: 'Choose a flaps font' translated andSendTo: self withSelector: #setFlapsFontTo: highlight: self standardFlapFont! Item was changed: ----- Method: Preferences class>>chooseWindowTitleFont (in category 'fonts') ----- chooseWindowTitleFont + self + chooseFontWithPrompt: 'Window Title font...' translated + andSendTo: self + withSelector: #setWindowTitleFontTo: + highlightSelector: #windowTitleFont! - self chooseFontWithPrompt: 'Choose the window title font' translated andSendTo: self withSelector: #setWindowTitleFontTo: highlight: self windowTitleFont! Item was changed: ----- Method: Preferences class>>chooseStandardButtonFont (in category 'fonts') ----- chooseStandardButtonFont + self + chooseFontWithPrompt: 'Button font...' translated + andSendTo: self + withSelector: #setButtonFontTo: + highlightSelector: #standardButtonFont - self chooseFontWithPrompt: 'Choose the button font' translated andSendTo: self withSelector: #setButtonFontTo: highlight: self standardButtonFont ! Item was changed: ----- Method: Preferences class>>chooseEToysFont (in category 'fonts') ----- chooseEToysFont "present a menu with the possible fonts for the eToys" self + chooseFontWithPrompt: 'eToys font...' translated - chooseFontWithPrompt: 'Choose the eToys font' translated andSendTo: self withSelector: #setEToysFontTo: + highlightSelector: #standardEToysFont! - highlight: self standardEToysFont! Item was changed: ----- Method: Preferences class>>chooseListFont (in category 'fonts') ----- chooseListFont + self + chooseFontWithPrompt: 'List font...' translated + andSendTo: self + withSelector: #setListFontTo: + highlightSelector: #standardListFont! - self chooseFontWithPrompt: 'Choose the standard list font' translated andSendTo: self withSelector: #setListFontTo: highlight: self standardListFont! Item was changed: ----- Method: Preferences class>>chooseHaloLabelFont (in category 'fonts') ----- chooseHaloLabelFont "present a menu with the possible fonts for label in halo" self + chooseFontWithPrompt: 'Halo Label font...' - chooseFontWithPrompt: 'halo label font' andSendTo: self withSelector: #setHaloLabelFontTo: + highlightSelector: #standardHaloLabelFont! - highlight: self standardHaloLabelFont! Item was changed: ----- Method: Preferences class>>chooseMenuFont (in category 'fonts') ----- chooseMenuFont + self + chooseFontWithPrompt: 'Menu font...' translated + andSendTo: self + withSelector: #setMenuFontTo: + highlightSelector: #standardMenuFont! - self chooseFontWithPrompt: 'Choose the standard menu font' translated andSendTo: self withSelector: #setMenuFontTo: highlight: self standardMenuFont! Item was added: + ----- Method: Preferences class>>standardSystemFont (in category 'fonts') ----- + standardSystemFont + "Answer the standard system font " + + ^(TextConstants at: #DefaultTextStyle) defaultFont! Item was changed: ----- Method: Preferences class>>chooseCodeFont (in category 'fonts') ----- chooseCodeFont "Not currently sent, but once protocols are sorted out so that we can disriminate on whether a text object being launched is for code or not, will be reincorporated" + self + chooseFontWithPrompt: 'Code font...' translated + andSendTo: self + withSelector: #setCodeFontTo: + highlightSelector: #standardCodeFont.! - self chooseFontWithPrompt: 'Choose the font to be used for displaying code' translated andSendTo: self withSelector: #setCodeFontTo: highlight: self standardCodeFont.! Item was changed: ----- Method: Preferences class>>chooseEToysTitleFont (in category 'fonts') ----- chooseEToysTitleFont "present a menu with the possible fonts for the eToys" self + chooseFontWithPrompt: 'eToys Title font...' translated - chooseFontWithPrompt: 'Choose the eToys title font' translated andSendTo: self withSelector: #setEToysTitleFontTo: + highlightSelector: #standardEToysTitleFont! - highlight: self standardEToysTitleFont!

1 0

The Trunk: MorphicExtras-ar.44.mcz
by commits＠source.squeak.org 31 Aug '09

31 Aug '09

Andreas Raab uploaded a new version of MorphicExtras to project The Trunk: http://source.squeak.org/trunk/MorphicExtras-ar.44.mcz ==================== Summary ==================== Name: MorphicExtras-ar.44 Author: ar Time: 30 August 2009, 5:18:50 am UUID: 77556604-c907-714e-8d84-aacd322ed0ec Ancestors: MorphicExtras-eem.43 FreeTypePlus integration. Fold extensions and overrides in CanvasCharacterScanner. =============== Diff against MorphicExtras-eem.43 =============== Item was changed: ----- Method: CanvasCharacterScanner>>tab (in category 'stop conditions') ----- tab + destX _ (alignment == Justified and: [self leadingTab not]) - destX := (alignment == Justified and: [self leadingTab not]) ifTrue: "imbedded tabs in justified text are weird" [destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX] ifFalse: [textStyle nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin]. + lastIndex _ lastIndex + 1. + pendingKernX := 0. - - lastIndex := lastIndex + 1. ^ false! Item was changed: ----- Method: CanvasCharacterScanner>>cr (in category 'stop conditions') ----- cr "When a carriage return is encountered, simply increment the pointer into the paragraph." + lastIndex_ lastIndex + 1. + pendingKernX := 0. - lastIndex:= lastIndex + 1. ^false! Item was changed: ----- Method: CanvasCharacterScanner>>paddedSpace (in category 'stop conditions') ----- paddedSpace "Each space is a stop condition when the alignment is right justified. Padding must be added to the base width of the space according to which space in the line this space is and according to the amount of space that remained at the end of the line when it was composed." + destX _ destX + spaceWidth + (line justifiedPadFor: spaceCount font: font). + lastIndex _ lastIndex + 1. + pendingKernX := 0. - destX := destX + spaceWidth + (line justifiedPadFor: spaceCount). - - lastIndex := lastIndex + 1. ^ false!

1 0

The Trunk: Morphic-ar.164.mcz
by commits＠source.squeak.org 31 Aug '09

31 Aug '09

Andreas Raab uploaded a new version of Morphic to project The Trunk: http://source.squeak.org/trunk/Morphic-ar.164.mcz ==================== Summary ==================== Name: Morphic-ar.164 Author: ar Time: 30 August 2009, 5:15:48 am UUID: b12dfe19-bea4-7a48-9de3-0fd4d8667090 Ancestors: Morphic-laza.163 First pass on FreeTypePlus integration: - Integrate overrides/extensions - Fold modal dialog support from Polymorph - Add FontChooserTool as a font chooser dialog - Use dialog in standard font choice places =============== Diff against Morphic-laza.163 =============== Item was added: + ----- Method: SystemWindow>>bringBehind: (in category 'polymorph') ----- + bringBehind: aMorph + "Make the receiver be directly behind the given morph. + Take into account any modal owner and propagate." + + |outerMorph| + outerMorph := self topRendererOrSelf. + outerMorph owner ifNil: [^ self "avoid spurious activate when drop in trash"]. + outerMorph owner addMorph: outerMorph after: aMorph topRendererOrSelf. + self modalOwner ifNotNilDo: [:mo | mo bringBehind: self]! Item was added: + ----- Method: SystemWindow>>modalChild (in category 'polymorph') ----- + modalChild + "Answer the modal child of the receiver, if any." + + ^self valueOfProperty: #modalChild! Item was changed: ----- Method: TextMorphEditor>>changeTextFont (in category 'attributes') ----- changeTextFont + "Present a dialog which allows the user to select a font, and if one is chosen, apply it to the current selection. If there is no selection, or the selection is empty, apply it to the whole morph." + | curFont startIndex chooser newFont | - "Present a menu of available fonts, and if one is chosen, apply it to the current selection. - If there is no selection, or the selection is empty, apply it to the whole morph." - | curFont newFont attr startIndex stopIndex | startIndex := self startIndex. - stopIndex := self stopIndex-1 min: paragraph text size. curFont := (paragraph text fontAt: startIndex withStyle: paragraph textStyle). + morph openModal: ( + Cursor wait showWhile: [ + (chooser := FontChooserTool default + withTitle: 'Change the selected text''s font to...' translated + for: self + setSelector: #changeSelectionFontTo: + getSelector: curFont) open]). + newFont := chooser result. + newFont ifNotNil:[self changeSelectionFontTo: newFont].! - newFont := StrikeFont fromUser: curFont allowKeyboard: false. - newFont ifNil:[^self]. - attr := TextFontReference toFont: newFont. - stopIndex >= startIndex - ifTrue: [ paragraph text addAttribute: attr from: startIndex to: stopIndex ] - ifFalse: [ paragraph text addAttribute: attr from: 1 to: paragraph text size. ]. - - paragraph composeAll. - self recomputeInterval. - ! Item was added: + ----- Method: FontChooserTool>>fontStyleList (in category 'style list') ----- + fontStyleList + "names of simulated styles are enclosed in parenthesis" + ^#('Regular' 'Bold' 'Italic' 'Bold Italic')! Item was added: + ----- Method: GrafPort>>lastFontForegroundColor (in category 'accessing') ----- + lastFontForegroundColor + ^lastFontForegroundColor! Item was added: + ----- Method: SystemWindow>>activateWindow (in category 'top window') ----- + activateWindow + "Bring me to the front and make me able to respond to mouse and keyboard. + Was #activate (sw 5/18/2001 23:20)" + + | oldTop outerMorph sketchEditor pal | + outerMorph := self topRendererOrSelf. + outerMorph owner ifNil: [^ self "avoid spurious activate when drop in trash"]. + oldTop := TopWindow. + oldTop = self ifTrue: [^self]. + TopWindow := self. + oldTop ifNotNil: [oldTop passivate]. + outerMorph owner firstSubmorph == outerMorph + ifFalse: ["Bring me (with any flex) to the top if not already" + outerMorph owner addMorphFront: outerMorph]. + self submorphsDo: [:m | m unlock]. + labelArea ifNotNil: + [labelArea submorphsDo: [:m | m unlock]. + self setStripeColorsFrom: self paneColorToUse]. + self isCollapsed ifFalse: + [model modelWakeUpIn: self. + self positionSubmorphs. + labelArea ifNil: [self adjustBorderUponActivationWhenLabeless]]. + + (sketchEditor := self extantSketchEditor) ifNotNil: + [sketchEditor comeToFront. + (pal := self world findA: PaintBoxMorph) ifNotNil: + [pal comeToFront]]. + ! Item was added: + ----- Method: TextLine>>justifiedPadFor:font: (in category 'scanning') ----- + justifiedPadFor: spaceIndex font: aFont + "Compute the width of pad for a given space in a line of justified text." + + | pad | + internalSpaces = 0 ifTrue: [^0]. + ^(aFont notNil and:[aFont isSubPixelPositioned]) + ifTrue:[paddingWidth * 1.0 / internalSpaces] + ifFalse:[ + pad _ paddingWidth // internalSpaces. + spaceIndex <= (paddingWidth \\ internalSpaces) + ifTrue: [pad + 1] + ifFalse: [pad]] + ! Item was added: + ----- Method: FontChooserTool>>selectedPointSizeIndex (in category 'point size') ----- + selectedPointSizeIndex + ^self pointSizeList indexOf: (pointSize reduce asString padded: #left to: 3 with: $ )! Item was added: + ----- Method: FontChooserTool>>buildWith: (in category 'toolbuilder') ----- + buildWith: builder + "Create the ui for the browser" + "ToolBuilder open: self" + | windowSpec | + windowSpec := self buildWindowWith: builder specs: { + (0@0 corner: 0.4(a)0.4) -> [self buildFontListWith: builder]. + (0.4@0 corner: 0.8(a)0.4) -> [self buildStyleListWith: builder]. + (0.8@0 corner: 1.0(a)0.4) -> [self buildPointSizeListWith: builder]. + (0.0(a)0.4 corner: 1.0(a)0.88) -> [self buildPreviewPaneWith: builder]. + (0.0(a)0.88 corner: 1@1) -> [self buildButtonBarWith: builder]. + }. + windowSpec extent: 400@300. + window := builder build: windowSpec. + ^window! Item was added: + ----- Method: Morph>>modalUnlockFrom: (in category 'polymorph') ----- + modalUnlockFrom: aSystemWindow + "Unlock the receiver as a modal owner of the given window." + + self unlock! Item was added: + ----- Method: SystemWindow>>rememberedKeyboardFocus (in category 'polymorph') ----- + rememberedKeyboardFocus + "Answer the remembered keyboard focus for the receiver." + + ^self valueOfProperty: #rememberedFocus! Item was added: + ----- Method: FontChooserTool>>open (in category 'toolbuilder') ----- + open + ^ToolBuilder open: self! Item was added: + ----- Method: FontChooserTool>>cancel (in category 'actions') ----- + cancel + result := nil. + ToolBuilder default close: window.! Item was added: + ----- Method: FontChooserTool>>buildPointSizeListWith: (in category 'toolbuilder') ----- + buildPointSizeListWith: builder + "Build the font choosers list of point sizes" + | listSpec | + listSpec := builder pluggableListSpec new. + listSpec + model: self; + list: #pointSizeList; + getIndex: #selectedPointSizeIndex; + setIndex: #selectedPointSizeIndex:. + ^listSpec + ! Item was added: + ----- Method: FontChooserTool class>>withTitle:for:setSelector:getSelector: (in category 'opening') ----- + withTitle: titleString for: anObject setSelector: setSelector getSelector: getSelector + " + (FontChooserTool + withTitle: 'Choose the Menu Font' + for: Preferences + setSelector: #setMenuFontTo: + getSelector: #standardMenuFont) open. + " + | instance | + instance := self new. + instance + title: titleString; + target: anObject; + setSelector: setSelector; + getSelector: getSelector. + ^instance! Item was added: + ----- Method: Morph>>openModal: (in category 'polymorph') ----- + openModal: aSystemWindow + "Open the given window locking the receiver until it is dismissed. + Answer the system window. + Restore the original keyboard focus when closed." + + |area mySysWin keyboardFocus| + keyboardFocus _ self activeHand keyboardFocus. + mySysWin := self isSystemWindow ifTrue: [self] ifFalse: [self ownerThatIsA: SystemWindow]. + mySysWin ifNil: [mySysWin := self]. + mySysWin modalLockTo: aSystemWindow. + ( RealEstateAgent respondsTo: #reduceByFlaps: ) + ifTrue:[ + area := RealEstateAgent reduceByFlaps: RealEstateAgent maximumUsableArea] + ifFalse:[ + area := RealEstateAgent maximumUsableArea]. + aSystemWindow extent: aSystemWindow initialExtent. + aSystemWindow position = (0@0) + ifTrue: [aSystemWindow + position: self activeHand position - (aSystemWindow extent // 2)]. + aSystemWindow + bounds: (aSystemWindow bounds translatedToBeWithin: area). + [ToolBuilder default runModal: aSystemWindow openAsIs] + ensure: [mySysWin modalUnlockFrom: aSystemWindow. + self activeHand newKeyboardFocus: keyboardFocus]. + ^aSystemWindow! Item was changed: ----- Method: TextEditor>>changeTextFont (in category 'attributes') ----- changeTextFont + "Present a dialog which allows the user to select a font, and if one is chosen, apply it to the current selection. If there is no selection, or the selection is empty, apply it to the whole morph." + | curFont startIndex chooser newFont | + startIndex := self startIndex. + curFont := (paragraph text fontAt: startIndex withStyle: paragraph textStyle). + morph openModal: ( + Cursor wait showWhile: [ + (chooser := FontChooserTool default + withTitle: 'Change the selected text''s font to...' translated + for: self + setSelector: #changeSelectionFontTo: + getSelector: curFont) open]). + newFont := chooser result. + newFont ifNotNil:[self changeSelectionFontTo: newFont].! - "Present a menu of available fonts, and if one is chosen, apply it to the current selection." - | curFont newFont attr startIndex | - startIndex _ self startIndex. - curFont _ (paragraph text fontAt: startIndex withStyle: paragraph textStyle). - newFont _ StrikeFont fromUser: curFont. - newFont ifNil:[^self]. - attr _ TextFontReference toFont: newFont. - paragraph text addAttribute: attr from: startIndex to: (self stopIndex-1 min: paragraph text size). - paragraph composeAll. - self recomputeInterval. - morph changed.! Item was added: + ----- Method: FontChooserTool class>>default: (in category 'accessing') ----- + default: aFontChooser + "Answer the default font chooser tool" + Default := aFontChooser! Item was added: + ----- Method: FontChooserTool>>windowTitle (in category 'initialize') ----- + windowTitle + ^ title translated! Item was added: + ----- Method: FontChooserTool>>selectedFontStyleIndex: (in category 'style list') ----- + selectedFontStyleIndex: anIndex + anIndex = 0 ifTrue: [^self]. + emphasis := anIndex - 1. + self changed: #selectedFontStyleIndex. + self changed: #contents.! Item was added: + ----- Method: FontChooserTool>>target (in category 'accessing') ----- + target + "Answer the value of target" + + ^ target! Item was added: + ----- Method: FontChooserTool>>selectedFontIndex (in category 'font list') ----- + selectedFontIndex + | font textStyleName family | + selectedFontIndex ifNotNil: [^selectedFontIndex]. + selectedFontIndex := 0. + font := (getSelector isSymbol and:[target notNil]) + ifTrue:[target perform: getSelector] + ifFalse:[getSelector]. + font ifNotNil:[ + emphasis := font emphasis. + pointSize := font pointSize. + textStyleName := font textStyleName. + family := self fontList detect:[:f | f = textStyleName] ifNone:[]. + ]. + selectedFontIndex := self fontList indexOf: family ifAbsent:[0]. + self selectedFontIndex: selectedFontIndex. + ^selectedFontIndex! Item was changed: ----- Method: BalloonMorph class>>chooseBalloonFont (in category 'utility') ----- chooseBalloonFont "BalloonMorph chooseBalloonFont" + Preferences + chooseFontWithPrompt: 'Ballon Help font...' translated + andSendTo: self + withSelector: #setBalloonFontTo: + highlightSelector: #balloonFont! - Preferences chooseFontWithPrompt: 'Select the font to be - used for balloon help' translated - andSendTo: self withSelector: #setBalloonFontTo: highlight: BalloonFont! Item was added: + ----- Method: FontChooserTool>>setSelector: (in category 'accessing') ----- + setSelector: anObject + "Set the value of setSelector" + + setSelector := anObject! Item was added: + ----- Method: FontChooserTool>>buildButtonBarWith: (in category 'toolbuilder') ----- + buildButtonBarWith: builder + "Build the button bar" + | panelSpec buttonSpec | + panelSpec := builder pluggablePanelSpec new. + panelSpec children: OrderedCollection new. + + buttonSpec := builder pluggableButtonSpec new. + buttonSpec + model: self; + label: ' Apply ' translated; + action: #apply; + frame: (0.0@0 corner: 0.33@1). + panelSpec children addLast: buttonSpec. + + + buttonSpec := builder pluggableButtonSpec new. + buttonSpec + model: self; + label: ' OK ' translated; + action: #accept; + frame: (0.33@0 corner: 0.67@1). + panelSpec children addLast: buttonSpec. + + buttonSpec := builder pluggableButtonSpec new. + buttonSpec + model: self; + label: ' Cancel ' translated; + action: #cancel; + frame: (0.67@0 corner: 1@1). + panelSpec children addLast: buttonSpec. + + ^panelSpec! Item was added: + ----- Method: Morph>>modalLockTo: (in category 'polymorph') ----- + modalLockTo: aSystemWindow + "Lock the receiver as a modal owner of the given window." + + self lock! Item was added: + ----- Method: FontChooserTool>>pointSize (in category 'point size') ----- + pointSize + ^pointSize ifNil: [pointSize := 10.0]! Item was added: + ----- Method: FontChooserTool>>buildWindowWith: (in category 'toolbuilder') ----- + buildWindowWith: builder + | windowSpec | + windowSpec := builder pluggableWindowSpec new. + windowSpec model: self. + windowSpec label: #windowTitle. + windowSpec children: OrderedCollection new. + ^windowSpec! Item was added: + ----- Method: FontChooserTool>>buildStyleListWith: (in category 'toolbuilder') ----- + buildStyleListWith: builder + "Build the font choosers list of font styles" + | listSpec | + listSpec := builder pluggableListSpec new. + listSpec + model: self; + list: #fontStyleList; + getIndex: #selectedFontStyleIndex; + setIndex: #selectedFontStyleIndex:. + ^listSpec + ! Item was added: + ----- Method: FontChooserTool>>title: (in category 'accessing') ----- + title: anObject + "Set the value of title" + + title := anObject! Item was changed: ----- Method: PluggableListMorph>>setListFont (in category 'menus') ----- setListFont "set the font for the list" + Preferences + chooseFontWithPrompt: 'Choose the font for this list' translated + andSendTo: self + withSelector: #font: + highlightSelector: #font! - Preferences chooseFontWithPrompt: 'Choose the font for this list' translated andSendTo: self withSelector: #font: highlight: self listMorph font! Item was changed: ----- Method: SystemWindow>>activate (in category 'top window') ----- activate + "Activate the owner too." - "Bring me to the front and make me able to respond to mouse and keyboard" + |mo mc| + mo := self modalOwner. + mc := self modalChild. + mc isNil + ifFalse: [mc owner notNil ifTrue: [ + mc activate. + ^mc modalChild isNil ifTrue: [mc flash]]]. + (self paneMorphs size > 1 and: [self splitters isEmpty]) + ifTrue: [self addPaneSplitters]. + self activateWindow. + self rememberedKeyboardFocus + ifNil: [(self respondsTo: #navigateFocusForward) + ifTrue: [self navigateFocusForward]] + ifNotNilDo: [:m | m world + ifNil: [self rememberKeyboardFocus: nil] "deleted" + ifNotNilDo: [:w | + m wantsKeyboardFocus + ifTrue: [m takeKeyboardFocus] + ifFalse: [(self respondsTo: #navigateFocusForward) + ifTrue: [self navigateFocusForward]]]]. + (mo notNil and: [mo isKindOf: SystemWindow]) + ifTrue: [mo bringBehind: self]! - | oldTop outerMorph sketchEditor pal | - outerMorph := self topRendererOrSelf. - outerMorph owner ifNil: [^ self "avoid spurious activate when drop in trash"]. - oldTop := TopWindow. - TopWindow := self. - oldTop ifNotNil: [oldTop passivate]. - outerMorph owner firstSubmorph == outerMorph - ifFalse: ["Bring me (with any flex) to the top if not already" - outerMorph owner addMorphFront: outerMorph]. - self submorphsDo: [:m | m unlock]. - labelArea ifNotNil: - [labelArea submorphsDo: [:m | m unlock]. - self setStripeColorsFrom: self paneColorToUse]. - self isCollapsed ifFalse: - [model modelWakeUpIn: self. - self positionSubmorphs. - labelArea ifNil: [self adjustBorderUponActivationWhenLabeless]]. - - (sketchEditor := self extantSketchEditor) ifNotNil: - [sketchEditor comeToFront. - (pal := self world findA: PaintBoxMorph) ifNotNil: - [pal comeToFront]]. - ! Item was added: + ----- Method: TextEditor>>changeTextFontDialog (in category 'attributes') ----- + changeTextFontDialog + "Present a dialog which allows the user to select a font, and if one is chosen, apply it to the current selection. If there is no selection, or the selection is empty, apply it to the whole morph." + | curFont startIndex chooser newFont | + startIndex := self startIndex. + curFont := (paragraph text fontAt: startIndex withStyle: paragraph textStyle). + (curFont isKindOf: LogicalFont) + ifTrue:[ + curFont := curFont copy. + ((paragraph text emphasisAt: startIndex) anyMask: 1) ifTrue:[curFont forceBold]. + ((paragraph text emphasisAt: startIndex) anyMask: 2) ifTrue:[curFont forceItalicOrOblique]. + curFont clearRealFont]. + morph openModal: ( + Cursor wait showWhile: [ + (chooser := FontChooserTool default + withTitle: 'Change the selected text''s font to...' translated + for: self + setSelector: #changeSelectionFontTo: + getSelector: curFont) open]). + newFont := chooser result. + newFont ifNotNil:[self changeSelectionFontTo: newFont].! Item was added: + ----- Method: FontChooserTool>>selectedPointSize (in category 'point size') ----- + selectedPointSize + ^self selectedFont pointSize! Item was added: + ----- Method: PasteUpMorph>>modalLockTo: (in category 'polymorph') ----- + modalLockTo: aSystemWindow + "Don't lock the world!! Lock the submorphs. + The modal window gets opened afterwards so is OK." + + |lockStates| + lockStates _ IdentityDictionary new. + self submorphsDo: [:m | + lockStates at: m put: m isLocked. + m lock]. + self + setProperty: #submorphLockStates + toValue: lockStates! Item was added: + ----- Method: FontChooserTool>>result (in category 'accessing') ----- + result + ^result! Item was added: + ----- Method: FontChooserTool>>contents (in category 'toolbuilder') ----- + contents + | sample i c f | + sample := WriteStream on: ''. + f := self selectedFont ifNil:[^Text new]. + f isSymbolFont ifFalse:[ + sample + nextPutAll: 'the quick brown fox jumps over the lazy dog' ;cr; + nextPutAll: 'THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG.' ;cr;cr; + nextPutAll: '0123456789'; cr; cr; + nextPutAll: 'Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.'; + yourself. + ] ifTrue:[ + i := 0. + 33 to: 255 do:[:ci | + sample nextPut: (c:=Character value: ci). + i := i + 1. + (('@Z`z' includes:c) or:[i = 30]) + ifTrue:[i :=0. sample cr]]. + ]. + sample := sample contents asText. + sample addAttribute: (TextFontReference toFont: f). + ^sample! Item was added: + ----- Method: FontChooserTool>>selectedPointSizeIndex: (in category 'point size') ----- + selectedPointSizeIndex: anIndex + + anIndex = 0 ifTrue: [^self]. + pointSize := (self pointSizeList at: anIndex) withBlanksTrimmed asNumber. + self changed: #pointSizeList. + self changed: #contents.! Item was added: + ----- Method: FontChooserTool>>selectedFontIndex: (in category 'font list') ----- + selectedFontIndex: anIndex + anIndex = 0 ifTrue: [^self]. + selectedFontIndex := anIndex. + self changed: #selectedFontIndex. + self changed: #selectedFontStyleIndex. + self changed: #pointSizeList. + self changed: #pointSizeIndex. + self changed: #contents.! Item was changed: ----- Method: StringMorph>>changeFont (in category 'menu') ----- changeFont + | newFont chooser| + chooser := self openModal: ( + Cursor wait showWhile: [UIManager default + chooseFont: 'Choose a Font' + for: self + setSelector: #font: + getSelector: self fontToUse]). + newFont := chooser result. - | newFont | - newFont := StrikeFont fromUser: self fontToUse. newFont ifNotNil:[self font: newFont].! Item was added: + ----- Method: FontChooserTool>>target: (in category 'accessing') ----- + target: anObject + "Set the value of target" + + target := anObject! Item was added: + ----- Method: FontChooserTool>>buildWindowWith:specs: (in category 'toolbuilder') ----- + buildWindowWith: builder specs: specs + | windowSpec rect action widgetSpec | + windowSpec := self buildWindowWith: builder. + specs do:[:assoc| + rect := assoc key. + action := assoc value. + widgetSpec := action value. + widgetSpec ifNotNil:[ + widgetSpec frame: rect. + windowSpec children add: widgetSpec]]. + ^windowSpec! Item was added: + ----- Method: FontChooserTool class>>openWithWindowTitle:for:setSelector:getSelector: (in category 'opening') ----- + openWithWindowTitle: titleString for: anObject setSelector: setSelector getSelector: getSelector + " + FontChooserTool + openWithWindowTitle: 'Choose the Menu Font' + for: Preferences + setSelector: #setMenuFontTo: + getSelector: #standardMenuFont. + " + ^(self withTitle: titleString for: anObject setSelector: setSelector getSelector: getSelector) open! Item was added: + ----- Method: FontChooserTool class>>windowTitle:for:setSelector:getSelector: (in category 'opening') ----- + windowTitle: titleString for: anObject setSelector: setSelector getSelector: getSelector + | instance | + + instance := self new. + instance + title: titleString; + target: anObject; + setSelector: setSelector; + getSelector: getSelector. + ^instance open! Item was added: + ----- Method: SystemWindow>>modalOwner (in category 'polymorph') ----- + modalOwner + "Answer the modal owner of the receiver, if any." + + ^self valueOfProperty: #modalOwner! Item was added: + ----- Method: PasteUpMorph>>modalUnlockFrom: (in category 'polymorph') ----- + modalUnlockFrom: aSystemWindow + "Don't unlock the world!! Unlock the submorphs + that were not originally locked." + + |lockStates| + lockStates := self + valueOfProperty: #submorphLockStates + ifAbsent: [^self]. + self removeProperty: #submorphLockStates. + lockStates keysAndValuesDo: [:m :locked | + locked ifFalse: [m unlock]]! Item was added: + ----- Method: FontChooserTool>>buildFontListWith: (in category 'toolbuilder') ----- + buildFontListWith: builder + "Build the font choosers list of font names" + | listSpec | + listSpec := builder pluggableListSpec new. + listSpec + model: self; + list: #fontList; + getIndex: #selectedFontIndex; + setIndex: #selectedFontIndex:. + ^listSpec + ! Item was added: + ----- Method: FontChooserTool>>getSelector (in category 'accessing') ----- + getSelector + "Answer the value of getSelector" + + ^ getSelector! Item was added: + ----- Method: FontChooserTool>>pointSizeList (in category 'point size') ----- + pointSizeList + ^self selectedFont textStyle pointSizes collect: [:each | each asString padded: #left to: 3 with: $ ]! Item was added: + ----- Method: FontChooserTool>>buildPreviewPaneWith: (in category 'toolbuilder') ----- + buildPreviewPaneWith: builder + "Build the preview panel" + | textSpec | + textSpec := builder pluggableTextSpec new. + textSpec + model: self; + getText: #contents. + ^textSpec! Item was added: + ----- Method: FontChooserTool>>selectedFontStyleIndex (in category 'style list') ----- + selectedFontStyleIndex + "This is a hack" + ^emphasis+1! Item was changed: ----- Method: TransformMorph>>drawSubmorphsOn: (in category 'drawing') ----- drawSubmorphsOn: aCanvas aCanvas transformBy: transform clippingTo: self innerBounds during: [:myCanvas | + (self angle ~= 0.0 or: [self scale ~= 1.0]) + ifTrue:[ + AbstractFont forceNonSubPixelDuring:[ + submorphs reverseDo:[:m | myCanvas fullDrawMorph: m] ] ] + ifFalse:[ + submorphs reverseDo:[:m | myCanvas fullDrawMorph: m] ] ] - submorphs reverseDo:[:m | myCanvas fullDrawMorph: m] ] smoothing: smoothing! Item was added: + Model subclass: #FontChooserTool + instanceVariableNames: 'title selectedFontIndex fontList target getSelector setSelector pointSize emphasis window result' + classVariableNames: 'Default' + poolDictionaries: '' + category: 'Morphic-Support'! + + !FontChooserTool commentStamp: 'ar 8/30/2009 14:28' prior: 0! + A ToolBuilder version of FreeTypePlus' FontChooser[Morph].! Item was added: + ----- Method: FontChooserTool class>>open (in category 'opening') ----- + open + " + FontChooserTool open. + " + ^self new open! Item was added: + ----- Method: SystemWindow>>modalUnlockFrom: (in category 'polymorph') ----- + modalUnlockFrom: aSystemWindow + "Unlock the receiver as a modal owner of the given window." + + aSystemWindow removeProperty: #modalOwner. + self removeProperty: #modalChild. + self activate! Item was changed: ----- Method: GrafPort>>installStrikeFont:foregroundColor:backgroundColor: (in category 'private') ----- installStrikeFont: aStrikeFont foregroundColor: foregroundColor backgroundColor: backgroundColor super installStrikeFont: aStrikeFont foregroundColor: foregroundColor backgroundColor: backgroundColor. - alpha := foregroundColor privateAlpha. aStrikeFont glyphs depth = 1 ifTrue: [ + alpha := foregroundColor privateAlpha. "dynamically switch between blend modes to support translucent text" "To handle the transition from TTCFont to StrikeFont, rule 34 must be taken into account." alpha = 255 ifTrue:[ combinationRule = 30 ifTrue: [combinationRule := Form over]. combinationRule = 31 ifTrue: [combinationRule := Form paint]. combinationRule = 34 ifTrue: [combinationRule := Form paint]. + combinationRule = 41 ifTrue: [combinationRule := Form paint]. "41 is SPRmode" ] ifFalse:[ combinationRule = Form over ifTrue: [combinationRule := 30]. combinationRule = Form paint ifTrue: [combinationRule := 31]. combinationRule = 34 ifTrue: [combinationRule := 31]. + combinationRule = 41 ifTrue: [combinationRule := 31]. "41 is SPR mode" + ] - ]. ]. lastFont := aStrikeFont. lastFontForegroundColor := foregroundColor. lastFontBackgroundColor := backgroundColor. ! Item was added: + ----- Method: FontChooserTool>>selectedFont (in category 'font list') ----- + selectedFont + | font family | + family := self fontList at: self selectedFontIndex ifAbsent:[^TextStyle defaultFont]. + font := (TextStyle named: family) fontOfPointSize: pointSize. + ^font emphasized: emphasis! Item was added: + ----- Method: FontChooserTool>>apply (in category 'actions') ----- + apply + | font | + target ifNotNil:[ + setSelector ifNotNil:[ + font := self selectedFont. + font ifNotNil:[ + target perform: setSelector with: font]]].! Item was added: + ----- Method: TextEditor>>changeSelectionFontTo: (in category 'attributes') ----- + changeSelectionFontTo: aFont + | attr | + aFont ifNil:[^self]. + attr _ TextFontReference toFont: aFont. + paragraph text addAttribute: attr from: self startIndex to: (self stopIndex-1 min: paragraph text size). + paragraph composeAll. + self recomputeInterval. + morph changed.! Item was added: + ----- Method: FontChooserTool class>>default (in category 'accessing') ----- + default + "Answer the default font chooser tool" + ^Default ifNil:[self]! Item was added: + ----- Method: FontChooserTool>>pointSize: (in category 'point size') ----- + pointSize: aNumber + pointSize := aNumber. + self changed: #pointSize. + self changed: #contents.! Item was added: + ----- Method: FontChooserTool>>selectedFontFamily (in category 'font list') ----- + selectedFontFamily + ^self fontList at: self selectedFontIndex ifAbsent:[nil]. + + ! Item was added: + ----- Method: FontChooserTool>>getSelector: (in category 'accessing') ----- + getSelector: aSelectorSymbolOrFont + "Set the value of getSelector" + + getSelector := aSelectorSymbolOrFont! Item was added: + ----- Method: FontChooserTool>>fontList (in category 'font list') ----- + fontList + "List of available font family names" + ^fontList ifNil:[fontList := (TextConstants select: [:each | each isKindOf: TextStyle]) keys asArray sort]! Item was added: + ----- Method: SystemWindow>>modalLockTo: (in category 'polymorph') ----- + modalLockTo: aSystemWindow + "Lock the receiver as a modal owner of the given window." + + aSystemWindow + setProperty: #modalOwner toValue: self. + self setProperty: #modalChild toValue: aSystemWindow! Item was added: + ----- Method: TextMorphEditor>>changeSelectionFontTo: (in category 'attributes') ----- + changeSelectionFontTo: aFont + | attr | + aFont ifNil:[^self]. + attr _ TextFontReference toFont: aFont. + paragraph text addAttribute: attr from: self startIndex to: (self stopIndex-1 min: paragraph text size). + paragraph composeAll. + self recomputeInterval. + morph changed.! Item was added: + ----- Method: FontChooserTool>>initialize (in category 'initialize') ----- + initialize + super initialize. + title := 'Choose A Font'. + getSelector := TextStyle defaultFont. + emphasis := 0.! Item was added: + ----- Method: FontChooserTool>>accept (in category 'actions') ----- + accept + self apply. + result := self selectedFont. + ToolBuilder default close: window.! Item was added: + ----- Method: FontChooserTool>>window (in category 'accessing') ----- + window + ^window! Item was added: + ----- Method: FontChooserTool>>initialExtent (in category 'initialize') ----- + initialExtent + ^400@300!

1 0

The Trunk: Graphics-ar.71.mcz
by commits＠source.squeak.org 31 Aug '09

31 Aug '09

Andreas Raab uploaded a new version of Graphics to project The Trunk: http://source.squeak.org/trunk/Graphics-ar.71.mcz ==================== Summary ==================== Name: Graphics-ar.71 Author: ar Time: 30 August 2009, 5:11:12 am UUID: 4fc068c9-df6c-8249-b8ee-5c9ab469a2dc Ancestors: Graphics-ar.70 First pass on FreeTypePlus integration. Deal with all of the overrides and add kerning support to CharacterScanner. This gets rid of all of the FTP extensions on Graphics package and the fumbling with CharacterScanner ivar list. =============== Diff against Graphics-ar.70 =============== Item was added: + ----- Method: AbstractFont>>linearWidthOf: (in category 'measuring') ----- + linearWidthOf: aCharacter + "This is the scaled, unrounded advance width." + ^self widthOf: aCharacter! Item was added: + ----- Method: AbstractFont>>kerningLeft:right: (in category 'kerning') ----- + kerningLeft: leftChar right: rightChar + ^0! Item was changed: ----- Method: CompositionScanner>>space (in category 'stop conditions') ----- space "Record left x and character index of the space character just encounted. Used for wrap-around. Answer whether the character has crossed the right edge of the composition rectangle of the paragraph." + pendingKernX := 0. spaceX := destX. destX := spaceX + spaceWidth. spaceIndex := lastIndex. lineHeightAtSpace := lineHeight. baselineAtSpace := baseline. lastIndex := lastIndex + 1. spaceCount := spaceCount + 1. destX > rightMargin ifTrue: [^self crossedX]. ^false ! Item was added: + ----- Method: AbstractFont class>>forceNonSubPixelCount (in category 'utilities') ----- + forceNonSubPixelCount + "Answer the force non-subpixel count" + ^ForceNonSubPixelCount ifNil:[ForceNonSubPixelCount := 0]! Item was changed: ----- Method: CompositionScanner>>crossedX (in category 'stop conditions') ----- crossedX "There is a word that has fallen across the right edge of the composition rectangle. This signals the need for wrapping which is done to the last space that was encountered, as recorded by the space stop condition." + pendingKernX := 0. spaceCount >= 1 ifTrue: ["The common case. First back off to the space at which we wrap." line stop: spaceIndex. lineHeight := lineHeightAtSpace. baseline := baselineAtSpace. spaceCount := spaceCount - 1. spaceIndex := spaceIndex - 1. "Check to see if any spaces preceding the one at which we wrap. Double space after punctuation, most likely." [(spaceCount > 1 and: [(text at: spaceIndex) = Space])] whileTrue: [spaceCount := spaceCount - 1. "Account for backing over a run which might change width of space." font := text fontAt: spaceIndex withStyle: textStyle. spaceIndex := spaceIndex - 1. spaceX := spaceX - (font widthOf: Space)]. line paddingWidth: rightMargin - spaceX. line internalSpaces: spaceCount] ifFalse: ["Neither internal nor trailing spaces -- almost never happens." lastIndex := lastIndex - 1. [destX <= rightMargin] whileFalse: [destX := destX - (font widthOf: (text at: lastIndex)). lastIndex := lastIndex - 1]. spaceX := destX. line paddingWidth: rightMargin - destX. line stop: (lastIndex max: line first)]. ^true! Item was added: + ----- Method: AbstractFont>>emphasisStringFor: (in category 'accessing') ----- + emphasisStringFor: emphasisCode + "Answer a translated string that represents the attributes given in emphasisCode." + + ^self class emphasisStringFor: emphasisCode! Item was added: + ----- Method: BitBlt>>combinationRule (in category 'accessing') ----- + combinationRule + "Answer the receiver's combinationRule" + + ^combinationRule! Item was added: + ----- Method: AbstractFont>>widthAndKernedWidthOfLeft:right:into: (in category 'kerning') ----- + widthAndKernedWidthOfLeft: leftCharacter right: rightCharacterOrNil into: aTwoElementArray + "Set the first element of aTwoElementArray to the width of leftCharacter and + the second element to the width of left character when kerned with + rightCharacterOrNil. Answer aTwoElementArray" + | w k | + w := self widthOf: leftCharacter. + rightCharacterOrNil isNil + ifTrue:[ + aTwoElementArray + at: 1 put: w; + at: 2 put: w] + ifFalse:[ + k := self kerningLeft: leftCharacter right: rightCharacterOrNil. + aTwoElementArray + at: 1 put: w; + at: 2 put: w+k]. + ^aTwoElementArray + ! Item was added: + ----- Method: AbstractFont>>displayUnderlineOn:from:to: (in category 'displaying') ----- + displayUnderlineOn: aDisplayContext from: baselineStartPoint to: baselineEndPoint + "display the underline if appropriate for the receiver"! Item was changed: ----- Method: CharacterBlockScanner>>paddedSpace (in category 'stop conditions') ----- paddedSpace "When the line is justified, the spaces will not be the same as the font's space character. A padding of extra space must be considered in trying to find which character the cursor is pointing at. Answer whether the scanning has crossed the cursor." | pad | pad := 0. spaceCount := spaceCount + 1. + pad := line justifiedPadFor: spaceCount font: font. - pad := line justifiedPadFor: spaceCount. lastSpaceOrTabExtent := lastCharacterExtent copy. self lastSpaceOrTabExtentSetX: spaceWidth + pad. (destX + lastSpaceOrTabExtent x) >= characterPoint x ifTrue: [lastCharacterExtent := lastSpaceOrTabExtent copy. ^self crossedX]. lastIndex := lastIndex + 1. destX := destX + lastSpaceOrTabExtent x. ^ false ! Item was changed: ----- Method: CompositionScanner>>tab (in category 'stop conditions') ----- tab "Advance destination x according to tab settings in the paragraph's textStyle. Answer whether the character has crossed the right edge of the composition rectangle of the paragraph." + pendingKernX := 0. destX := textStyle nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin. destX > rightMargin ifTrue: [^self crossedX]. lastIndex := lastIndex + 1. ^false ! Item was changed: ----- Method: CompositionScanner>>columnBreak (in category 'stop conditions') ----- columnBreak "Answer true. Set up values for the text line interval currently being composed." + pendingKernX := 0. line stop: lastIndex. spaceX := destX. line paddingWidth: rightMargin - spaceX. ^true! Item was changed: ----- Method: CompositionScanner>>cr (in category 'stop conditions') ----- cr "Answer true. Set up values for the text line interval currently being composed." + pendingKernX := 0. line stop: lastIndex. spaceX := destX. line paddingWidth: rightMargin - spaceX. ^true! Item was changed: ----- Method: CharacterBlockScanner>>crossedX (in category 'stop conditions') ----- crossedX "Text display has wrapping. The scanner just found a character past the x location of the cursor. We know that the cursor is pointing at a character or before one." | leadingTab currentX | characterIndex == nil ifFalse: [ "If the last character of the last line is a space, and it crosses the right margin, then locating the character block after it is impossible without this hack." characterIndex > text size ifTrue: [ lastIndex := characterIndex. characterPoint := (nextLeftMargin ifNil: [leftMargin]) @ (destY + line lineHeight). ^true]]. characterPoint x <= (destX + (lastCharacterExtent x // 2)) ifTrue: [lastCharacter := (text at: lastIndex). characterPoint := destX @ destY. ^true]. lastIndex >= line last ifTrue: [lastCharacter := (text at: line last). characterPoint := destX @ destY. ^true]. "Pointing past middle of a character, return the next character." lastIndex := lastIndex + 1. lastCharacter := text at: lastIndex. currentX := destX + lastCharacterExtent x + kern. self lastCharacterExtentSetX: (font widthOf: lastCharacter). characterPoint := currentX @ destY. lastCharacter = Space ifFalse: [^ true]. "Yukky if next character is space or tab." alignment = Justified ifTrue: [self lastCharacterExtentSetX: + (lastCharacterExtent x + (line justifiedPadFor: (spaceCount + 1) font: font)). - (lastCharacterExtent x + (line justifiedPadFor: (spaceCount + 1))). ^ true]. true ifTrue: [^ true]. "NOTE: I find no value to the following code, and so have defeated it - DI" "See tabForDisplay for illumination on the following awfulness." leadingTab := true. line first to: lastIndex - 1 do: [:index | (text at: index) ~= Tab ifTrue: [leadingTab := false]]. (alignment ~= Justified or: [leadingTab]) ifTrue: [self lastCharacterExtentSetX: (textStyle nextTabXFrom: currentX leftMargin: leftMargin rightMargin: rightMargin) - currentX] ifFalse: [self lastCharacterExtentSetX: (((currentX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount))) - currentX) max: 0)]. ^ true! Item was changed: Object subclass: #AbstractFont instanceVariableNames: '' + classVariableNames: 'ForceNonSubPixelCount' - classVariableNames: '' poolDictionaries: '' category: 'Graphics-Fonts'! !AbstractFont commentStamp: '<historical>' prior: 0! AbstractFont defines the generic interface that all fonts need to implement.! Item was changed: Object subclass: #CharacterScanner + instanceVariableNames: 'destX lastIndex xTable destY stopConditions text textStyle alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth emphasisCode kern indentationLevel wantsColumnBreaks pendingKernX' - instanceVariableNames: 'destX lastIndex xTable destY stopConditions text textStyle alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth emphasisCode kern indentationLevel wantsColumnBreaks' classVariableNames: 'DefaultStopConditions NilCondition PaddedSpaceCondition SpaceCondition' poolDictionaries: 'TextConstants' category: 'Graphics-Text'! !CharacterScanner commentStamp: '<historical>' prior: 0! My instances hold the state associated with scanning text. My subclasses scan characters for specified purposes, such as computing a CharacterBlock or placing characters into Forms.! Item was changed: ----- Method: DisplayScanner>>paddedSpace (in category 'stop conditions') ----- paddedSpace "Each space is a stop condition when the alignment is right justified. Padding must be added to the base width of the space according to which space in the line this space is and according to the amount of space that remained at the end of the line when it was composed." spaceCount := spaceCount + 1. + destX := destX + spaceWidth + (line justifiedPadFor: spaceCount font: font). - destX := destX + spaceWidth + (line justifiedPadFor: spaceCount). lastIndex := lastIndex + 1. ^ false! Item was changed: ----- Method: CharacterScanner>>setFont (in category 'private') ----- setFont | priorFont | "Set the font and other emphasis." priorFont := font. text == nil ifFalse:[ emphasisCode := 0. kern := 0. indentationLevel := 0. alignment := textStyle alignment. font := nil. (text attributesAt: lastIndex forStyle: textStyle) do: [:att | att emphasizeScanner: self]]. font == nil ifTrue: [self setFont: textStyle defaultFontIndex]. font := font emphasized: emphasisCode. + priorFont + ifNotNil: [ + font = priorFont + ifTrue:[ + "font is the same, perhaps the color has changed? + We still want kerning between chars of the same + font, but of different color. So add any pending kern to destX" + destX := destX + (pendingKernX ifNil:[0])]. + destX := destX + priorFont descentKern]. + pendingKernX := 0. "clear any pending kern so there is no danger of it being added twice" - priorFont ifNotNil: [destX := destX + priorFont descentKern]. destX := destX - font descentKern. "NOTE: next statement should be removed when clipping works" leftMargin ifNotNil: [destX := destX max: leftMargin]. kern := kern - font baseKern. "Install various parameters from the font." spaceWidth := font widthOf: Space. xTable := font xTable. stopConditions := DefaultStopConditions.! Item was changed: ----- Method: TextStyle class>>emphasisMenuForFont:target:selector:highlight: (in category 'user interface') ----- emphasisMenuForFont: font target: target selector: selector highlight: currentEmphasis "Offer a font emphasis menu for the given style. If one is selected, pass that font to target with a call to selector. The fonts will be displayed in that font. Answer nil if no derivatives exist. " | aMenu derivs | derivs := font derivativeFonts. derivs isEmpty ifTrue: [ ^nil ]. aMenu := MenuMorph entitled: 'emphasis' translated. derivs := derivs asOrderedCollection. derivs addFirst: font. derivs do: [ :df | aMenu + add: df emphasisString - add: (AbstractFont emphasisStringFor: df emphasis) target: target selector: selector argument: df. aMenu lastItem font: df. df emphasis == currentEmphasis ifTrue: [aMenu lastItem color: Color blue darker]]. ^ aMenu! Item was changed: ----- Method: TextStyle class>>fontMenuForStyle:target:selector:highlight: (in category 'user interface') ----- fontMenuForStyle: styleName target: target selector: selector highlight: currentFont "Offer a font menu for the given style. If one is selected, pass that font to target with a call to selector. The fonts will be displayed in that font." + | aMenu displayFont | - | aMenu | aMenu := MenuMorph entitled: styleName. (TextStyle named: styleName) ifNotNilDo: [:s | s isTTCStyle ifTrue: [aMenu add: 'New Size' target: self selector: #chooseTTCFontSize: argument: {styleName. target. selector}]]. (self pointSizesFor: styleName) do: [:pointSize | | font subMenu | font := (self named: styleName) fontOfPointSize: pointSize. subMenu := self emphasisMenuForFont: font target: target selector: selector highlight: (currentFont ifNotNilDo: [:cf | (cf familyName = styleName and: [cf pointSize = font pointSize]) ifTrue: [currentFont emphasis]]). subMenu ifNil: [aMenu add: pointSize asString , ' Point' target: target selector: selector argument: font] ifNotNil: [aMenu add: pointSize asString , ' Point' subMenu: subMenu]. + displayFont := font. + (font isSymbolFont or:[(font hasDistinctGlyphsForAll: pointSize asString , ' Point') not]) + ifTrue:[ + "don't use a symbol font to display its own name!!!!" + displayFont := self default fontOfPointSize: pointSize]. + aMenu lastItem font: displayFont. - aMenu lastItem font: font. currentFont ifNotNilDo: [:cf | (cf familyName = styleName and: [cf pointSize = font pointSize]) ifTrue: [aMenu lastItem color: Color blue darker]]]. ^ aMenu! Item was changed: ----- Method: CharacterScanner>>basicScanCharactersFrom:to:in:rightX:stopConditions:kern: (in category 'scanning') ----- basicScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta "Primitive. This is the inner loop of text display--but see scanCharactersFrom: to:rightX: which would get the string, stopConditions and displaying from the instance. March through source String from startIndex to stopIndex. If any character is flagged with a non-nil entry in stops, then return the corresponding value. Determine width of each character from xTable, indexed by map. If dextX would exceed rightX, then return stops at: 258. Advance destX by the width of the character. If stopIndex has been reached, then return stops at: 257. Optional. See Object documentation whatIsAPrimitive." + | ascii nextDestX char floatDestX widthAndKernedWidth nextChar atEndOfRun | - | ascii nextDestX char | <primitive: 103> lastIndex := startIndex. + floatDestX := destX. + widthAndKernedWidth := Array new: 2. + atEndOfRun := false. [lastIndex <= stopIndex] whileTrue: [char := (sourceString at: lastIndex). ascii := char asciiValue + 1. (stops at: ascii) == nil ifFalse: [^stops at: ascii]. "Note: The following is querying the font about the width since the primitive may have failed due to a non-trivial mapping of characters to glyphs or a non-existing xTable." + nextChar := (lastIndex + 1 <= stopIndex) + ifTrue:[sourceString at: lastIndex + 1] + ifFalse:[ + atEndOfRun := true. + "if there is a next char in sourceString, then get the kern + and store it in pendingKernX" + lastIndex + 1 <= sourceString size + ifTrue:[sourceString at: lastIndex + 1] + ifFalse:[ nil]]. + font + widthAndKernedWidthOfLeft: char + right: nextChar + into: widthAndKernedWidth. + nextDestX := floatDestX + (widthAndKernedWidth at: 1). - nextDestX := destX + (font widthOf: char). nextDestX > rightX ifTrue: [^stops at: CrossedX]. + floatDestX := floatDestX + kernDelta + (widthAndKernedWidth at: 2). + atEndOfRun + ifTrue:[ + pendingKernX := (widthAndKernedWidth at: 2) - (widthAndKernedWidth at: 1). + floatDestX := floatDestX - pendingKernX]. + destX := floatDestX. - destX := nextDestX + kernDelta. lastIndex := lastIndex + 1]. lastIndex := stopIndex. ^stops at: EndOfRun! Item was added: + ----- Method: AbstractFont class>>forceNonSubPixelDuring: (in category 'utilities') ----- + forceNonSubPixelDuring: aBlock + "Forces all font rendering to suppress subpixel anti-aliasing during the execution of aBlock" + ForceNonSubPixelCount ifNil:[ForceNonSubPixelCount := 0]. + ForceNonSubPixelCount := ForceNonSubPixelCount + 1. + aBlock ensure:[ForceNonSubPixelCount := ForceNonSubPixelCount - 1]! Item was added: + ----- Method: TextLineInterval>>justifiedPadFor:font: (in category 'scanning') ----- + justifiedPadFor: spaceIndex font: aFont + "Compute the width of pad for a given space in a line of justified text." + + | pad | + internalSpaces = 0 ifTrue: [^0]. + ^(aFont notNil and:[aFont isSubPixelPositioned]) + ifTrue:[paddingWidth * 1.0 / internalSpaces] + ifFalse:[ + pad := paddingWidth // internalSpaces. + spaceIndex <= (paddingWidth \\ internalSpaces) + ifTrue: [pad + 1] + ifFalse: [pad]]! Item was added: + ----- Method: AbstractFont>>hasGlyphsForAll: (in category 'testing') ----- + hasGlyphsForAll: asciiString + "Answer true if the receiver has glyphs for all the characters + in asciiString, false otherwise. + The default behaviour is to answer true, but subclasses may reimplement" + + ^true! Item was changed: ----- Method: TextStyle>>addNewFontSize: (in category 'fonts and font indexes') ----- addNewFontSize: pointSize "Add a font in specified size to the array of fonts." + | f d newArray t isSet | - | f d newArray t isSet fallbackStyle | fontArray first emphasis ~= 0 ifTrue: [ t := TextConstants at: self fontArray first familyName asSymbol. t fonts first emphasis = 0 ifTrue: [ ^ t addNewFontSize: pointSize. ]. ]. pointSize <= 0 ifTrue: [^ nil]. fontArray do: [:s | s pointSize = pointSize ifTrue: [^ s]. ]. (isSet := fontArray first isKindOf: TTCFontSet) ifTrue:[ | fonts | fonts := fontArray first fontArray collect: [ :font | | newFont | (font isNil) ifTrue: [newFont := nil] ifFalse: [ newFont := (font ttcDescription size > 256) ifTrue: [MultiTTCFont new initialize] ifFalse: [TTCFont new initialize]. newFont ttcDescription: font ttcDescription. newFont pixelSize: pointSize * 96 // 72. font derivativeFonts notEmpty ifTrue: [font derivativeFonts do: [ :proto | proto ifNotNil: [ d := proto class new initialize. d ttcDescription: proto ttcDescription. d pixelSize: newFont pixelSize. newFont derivativeFont: d]]]. ]. newFont]. f := TTCFontSet newFontArray: fonts] ifFalse: [ + f := fontArray first class new initialize: fontArray first. - f := TTCFont new initialize. - f ttcDescription: fontArray first ttcDescription. f pointSize: pointSize. fontArray first derivativeFonts do: [:proto | proto ifNotNil: [ + d := proto class new initialize: proto. - d := TTCFont new initialize. - d ttcDescription: proto ttcDescription. d pointSize: f pointSize. + f derivativeFont: d mainFont: proto. - f derivativeFont: d. ]. ]. - ]. - isSet ifFalse: [ - fallbackStyle := TextStyle named: (fontArray first fallbackFont textStyleName). ]. newArray := ((fontArray copyWith: f) asSortedCollection: [:a :b | a pointSize <= b pointSize]) asArray. self newFontArray: newArray. isSet ifTrue: [ TTCFontSet register: newArray at: newArray first familyName asSymbol. ]. - isSet ifFalse: [ - f setupDefaultFallbackFontTo: fallbackStyle. - f derivativeFonts do: [:g | g setupDefaultFallbackFontTo: fallbackStyle]. - ]. ^ self fontOfPointSize: pointSize ! Item was added: + ----- Method: AbstractFont>>isSubPixelPositioned (in category 'testing') ----- + isSubPixelPositioned + "Answer true if the receiver is currently using subpixel positioned + glyphs, false otherwise. This affects how padded space sizes are calculated + when composing text. + Currently, only FreeTypeFonts are subPixelPositioned, and only when not + Hinted" + + ^false ! Item was added: + ----- Method: AbstractFont>>isSymbolFont (in category 'testing') ----- + isSymbolFont + "Answer true if the receiver is a Symbol font, false otherwise. + The default is to answer false, subclasses can reimplement" + + ^false! Item was added: + ----- Method: AbstractFont>>displayStrikeoutOn:from:to: (in category 'displaying') ----- + displayStrikeoutOn: aDisplayContext from: baselineStartPoint to: baselineEndPoint + "display the strikeout if appropriate for the receiver"! Item was added: + ----- Method: AbstractFont>>hasDistinctGlyphsForAll: (in category 'testing') ----- + hasDistinctGlyphsForAll: asciiString + "Answer true if the receiver has glyphs for all the characters + in asciiString and no single glyph is shared by more than one character, false otherwise. + The default behaviour is to answer true, but subclasses may reimplement" + + ^true! Item was changed: + ----- Method: AbstractFont class>>emphasisStringFor: (in category 'utilities') ----- - ----- Method: AbstractFont class>>emphasisStringFor: (in category 'as yet unclassified') ----- emphasisStringFor: emphasisCode "Answer a translated string that represents the attributes given in emphasisCode." | emphases bit | emphasisCode = 0 ifTrue: [ ^'Normal' translated ]. emphases := (IdentityDictionary new) at: 1 put: 'Bold' translated; at: 2 put: 'Italic' translated; at: 4 put: 'Underlined' translated; at: 8 put: 'Narrow' translated; at: 16 put: 'StruckOut' translated; yourself. bit := 1. ^String streamContents: [ :s | [ bit < 32 ] whileTrue: [ | code | code := emphasisCode bitAnd: bit. code isZero ifFalse: [ s nextPutAll: (emphases at: code); space ]. bit := bit bitShift: 1 ]. s position isZero ifFalse: [ s skip: -1 ]. ]! Item was changed: ----- Method: CharacterScanner>>columnBreak (in category 'scanning') ----- columnBreak + pendingKernX := 0. ^true! Item was added: + ----- Method: AbstractFont>>emphasisString (in category 'accessing') ----- + emphasisString + "Answer a translated string that represents the receiver's emphasis." + + ^self emphasisStringFor: self emphasis!

1 0

The Trunk: KernelTests-laza.88.mcz
by commits＠source.squeak.org 31 Aug '09

31 Aug '09

Alexander Lazarević uploaded a new version of KernelTests to project The Trunk: http://source.squeak.org/trunk/KernelTests-laza.88.mcz ==================== Summary ==================== Name: KernelTests-laza.88 Author: laza Time: 31 August 2009, 1:51:50 am UUID: 148a355e-e76f-6d4d-bcff-11f14baee335 Ancestors: KernelTests-laza.86 Only remove obsolete BlockContext tests that fail =============== Diff against KernelTests-laza.86 =============== Item was changed: ----- Method: BlockContextTest>>testSetUp (in category 'tests') ----- testSetUp "Note: In addition to verifying that the setUp worked the way it was expected to, testSetUp is used to illustrate the meaning of the simple access methods, methods that are not normally otherwise 'tested'" - self deny: aBlockContext isClosure. self deny: aBlockContext isMethodContext. self deny: aBlockContext isPseudoContext. - self deny: aBlockContext isDead. self assert: aBlockContext home = contextOfaBlockContext. - self assert: aBlockContext blockHome = contextOfaBlockContext. self assert: aBlockContext receiver = self. self assert: (aBlockContext method isKindOf: CompiledMethod). + ! - self assert: aBlockContext methodNode selector = 'setUp'. - self assert: (aBlockContext methodNodeFormattedAndDecorated: true) selector = 'setUp'.! Item was removed: - ----- Method: BlockContextTest>>testSupplyAnswerUsingTraditionalMatchOfQuestion (in category 'tests') ----- - testSupplyAnswerUsingTraditionalMatchOfQuestion - - self should: [true = ([self confirm: 'You like Smalltalk?'] - valueSupplyingAnswer: #('*Smalltalk#' true))]! Item was removed: - ----- Method: BlockContextTest>>testCopyStack (in category 'tests') ----- - testCopyStack - self assert: aBlockContext copyStack printString = aBlockContext printString.! Item was removed: - ----- Method: BlockContextTest>>testSupplyAnswerThroughNestedBlocks (in category 'tests') ----- - testSupplyAnswerThroughNestedBlocks - - self should: [true = ([[self confirm: 'You like Smalltalk?'] - valueSupplyingAnswer: #('Blub' false)] valueSupplyingAnswer: #('Smalltalk' true))]! Item was removed: - ----- Method: BlockContextTest>>testSupplySameAnswerToAllQuestions (in category 'tests') ----- - testSupplySameAnswerToAllQuestions - - self should: [true = ([self confirm: 'You like Smalltalk?'] valueSupplyingAnswer: true)]. - - self should: [#(true true) = ([{self confirm: 'One'. self confirm: 'Two'}] valueSupplyingAnswer: true)].! Item was removed: - ----- Method: BlockContextTest>>testTallyMethods (in category 'tests') ----- - testTallyMethods - self assert: (ContextPart tallyMethods: aBlockContext) size = 3.! Item was removed: - ----- Method: BlockContextTest>>testValueWithExitContinue (in category 'tests - evaluating') ----- - testValueWithExitContinue - - | val last | - val := 0. - - 1 to: 10 do: [ :i | - [ :continue | - i = 4 ifTrue: [continue value]. - val := val + 1. - last := i - ] valueWithExit. - ]. - - self assert: val = 9. - self assert: last = 10. ! Item was removed: - ----- Method: BlockContextTest>>testSupplySeveralAnswersToSeveralQuestions (in category 'tests') ----- - testSupplySeveralAnswersToSeveralQuestions - - self should: [#(false true) = ([{self confirm: 'One'. self confirm: 'Two'}] - valueSupplyingAnswers: #( ('One' false) ('Two' true) ))]. - - self should: [#(true false) = ([{self confirm: 'One'. self confirm: 'Two'}] - valueSupplyingAnswers: #( ('One' true) ('Two' false) ))]! Item was removed: - ----- Method: BlockContextTest>>testTrace (in category 'tests') ----- - testTrace - self assert: (ContextPart trace: aBlockContext) class = Rectangle.! Item was removed: - ----- Method: BlockContextTest>>testValueWithExitBreak (in category 'tests - evaluating') ----- - testValueWithExitBreak - - | val | - - [ :break | - 1 to: 10 do: [ :i | - val := i. - i = 4 ifTrue: [break value]. - ] - ] valueWithExit. - - self assert: val = 4.! Item was removed: - ----- Method: BlockContextTest>>testFindContextSuchThat (in category 'tests') ----- - testFindContextSuchThat - self assert: (aBlockContext findContextSuchThat: [:each| true]) printString = aBlockContext printString. - self assert: (aBlockContext hasContext: aBlockContext). ! Item was removed: - ----- Method: BlockContextTest>>testBlockIsBottomContext (in category 'tests') ----- - testBlockIsBottomContext - self should: [aBlockContext client ] raise: Error. "block's sender is nil, a block has no client" - self assert: aBlockContext bottomContext = aBlockContext. - self assert: aBlockContext secondFromBottom isNil.! Item was removed: - ----- Method: BlockContextTest>>testValueWithArguments (in category 'tests - evaluating') ----- - testValueWithArguments - self - should: [aBlockContext - valueWithArguments: #(1 )] - raise: Error. - self - shouldnt: [aBlockContext - valueWithArguments: #()] - raise: Error. - [aBlockContext - valueWithArguments: #(1 )] - ifError: [:err :rcvr | self assert: err = 'Error: This block accepts 0 arguments, but was called with 1.']. - [[:i | 3 + 4] - valueWithArguments: #(1 2)] - ifError: [:err :rcvr | self assert: err = 'Error: This block accepts 1 argument, but was called with 2.']!

1 0

The Trunk: KernelTests-laza.87.mcz
by commits＠source.squeak.org 31 Aug '09

31 Aug '09

Alexander Lazarević uploaded a new version of KernelTests to project The Trunk: http://source.squeak.org/trunk/KernelTests-laza.87.mcz ==================== Summary ==================== Name: KernelTests-laza.87 Author: laza Time: 31 August 2009, 1:24:44 am UUID: 7bbafac0-f203-f94c-95de-ce3b9a575c4a Ancestors: KernelTests-laza.86 Remove obsolete BlockContext tests =============== Diff against KernelTests-laza.86 =============== Item was removed: - ----- Method: BlockContextTest>>testSupplyAnswerUsingTraditionalMatchOfQuestion (in category 'tests') ----- - testSupplyAnswerUsingTraditionalMatchOfQuestion - - self should: [true = ([self confirm: 'You like Smalltalk?'] - valueSupplyingAnswer: #('*Smalltalk#' true))]! Item was removed: - ----- Method: BlockContextTest>>testDecompile (in category 'tests - printing') ----- - testDecompile - self assert: ([3 + 4] decompile printString = '{[3 + 4]}').! Item was removed: - ----- Method: BlockContextTest>>testSupplyAnswerUsingRegexMatchOfQuestion (in category 'tests') ----- - testSupplyAnswerUsingRegexMatchOfQuestion - - (String includesSelector: #matchesRegex:) ifFalse: [^ self]. - - self should: [true = ([self confirm: 'You like Smalltalk?'] - valueSupplyingAnswer: #('.*Smalltalk\?' true))]! Item was removed: - ----- Method: BlockContextTest>>testSetUp (in category 'tests') ----- - testSetUp - "Note: In addition to verifying that the setUp worked the way it was expected to, testSetUp is used to illustrate the meaning of the simple access methods, methods that are not normally otherwise 'tested'" - self deny: aBlockContext isClosure. - self deny: aBlockContext isMethodContext. - self deny: aBlockContext isPseudoContext. - self deny: aBlockContext isDead. - self assert: aBlockContext home = contextOfaBlockContext. - self assert: aBlockContext blockHome = contextOfaBlockContext. - self assert: aBlockContext receiver = self. - self assert: (aBlockContext method isKindOf: CompiledMethod). - self assert: aBlockContext methodNode selector = 'setUp'. - self assert: (aBlockContext methodNodeFormattedAndDecorated: true) selector = 'setUp'.! Item was removed: - ----- Method: BlockContextTest>>testCopyStack (in category 'tests') ----- - testCopyStack - self assert: aBlockContext copyStack printString = aBlockContext printString.! Item was removed: - ----- Method: BlockContextTest>>testValueWithPossibleArgument (in category 'tests - evaluating') ----- - testValueWithPossibleArgument - | block blockWithArg blockWith2Arg | - - block := [1]. - blockWithArg := [:arg | arg]. - blockWith2Arg := [:arg1 :arg2 | {arg1. arg2}]. - - self assert: (block valueWithPossibleArgument: 1) = 1. - - self assert: (blockWithArg valueWithPossibleArgument: 1) = 1. - - self assert: (blockWith2Arg valueWithPossibleArgument: 1) = {1 . nil}. - - - ! Item was removed: - ----- Method: BlockContextTest>>testNew (in category 'tests') ----- - testNew - self should: [ContextPart new: 5] raise: Error. - [ContextPart new: 5] - ifError: [:error :receiver | error = 'Error: Contexts must only be created with newForMethod:']. - [ContextPart new] - ifError: [:error :receiver | error = 'Error: Contexts must only be created with newForMethod:']. - [ContextPart basicNew] - ifError: [:error :receiver | error = 'Error: Contexts must only be created with newForMethod:']. - - ! Item was removed: - ----- Method: BlockContextTest>>testOneArgument (in category 'tests') ----- - testOneArgument - | c | - c := OrderedCollection new. - c add: 'hello'. - [c - do: [1 + 2]] - ifError: [:err :rcvr | self deny: err = 'This block requires 0 arguments.']. - [c - do: [:arg1 :arg2 | 1 + 2]] - ifError: [:err :rcvr | self deny: err = 'This block requires 2 arguments.'] ! Item was removed: - ----- Method: BlockContextTest>>testSupplyAnswerThroughNestedBlocks (in category 'tests') ----- - testSupplyAnswerThroughNestedBlocks - - self should: [true = ([[self confirm: 'You like Smalltalk?'] - valueSupplyingAnswer: #('Blub' false)] valueSupplyingAnswer: #('Smalltalk' true))]! Item was removed: - ----- Method: BlockContextTest>>testSupplyAnswerOfFillInTheBlank (in category 'testing') ----- - testSupplyAnswerOfFillInTheBlank - - self should: ['blue' = ([UIManager default request: 'Your favorite color?'] - valueSupplyingAnswer: #('Your favorite color?' 'blue'))]! Item was removed: - ----- Method: BlockContextTest>>testTallyInstructions (in category 'tests') ----- - testTallyInstructions - self assert: (ContextPart tallyInstructions: aBlockContext) size = 15.! Item was removed: - ----- Method: BlockContextTest>>testRunSimulated (in category 'tests') ----- - testRunSimulated - self assert: (ContextPart runSimulated: aBlockContext) class = Rectangle.! Item was removed: - ----- Method: BlockContextTest>>testSupplyAnswerOfFillInTheBlankUsingDefaultAnswer (in category 'testing') ----- - testSupplyAnswerOfFillInTheBlankUsingDefaultAnswer - - self should: ['red' = ([UIManager default request: 'Your favorite color?' initialAnswer: 'red'] - valueSupplyingAnswer: #('Your favorite color?' #default))]! Item was removed: - ----- Method: BlockContextTest>>testSupplySameAnswerToAllQuestions (in category 'tests') ----- - testSupplySameAnswerToAllQuestions - - self should: [true = ([self confirm: 'You like Smalltalk?'] valueSupplyingAnswer: true)]. - - self should: [#(true true) = ([{self confirm: 'One'. self confirm: 'Two'}] valueSupplyingAnswer: true)].! Item was removed: - ----- Method: BlockContextTest>>testSuppressInformUsingStringMatchOptions (in category 'tests') ----- - testSuppressInformUsingStringMatchOptions - - self should: [([nil inform: 'Should not see this message or this test failed!!'] valueSuppressingMessages: #('Should not see this message or this test failed!!')) isNil]. - - self should: [([nil inform: 'Should not see this message or this test failed!!'] valueSuppressingMessages: #('not see this message')) isNil]. - - self should: [([nil inform: 'Should not see this message or this test failed!!'] valueSuppressingMessages: #('*message*failed#')) isNil]. - ! Item was removed: - TestCase subclass: #BlockContextTest - instanceVariableNames: 'aBlockContext contextOfaBlockContext' - classVariableNames: '' - poolDictionaries: '' - category: 'KernelTests-Methods'! - - !BlockContextTest commentStamp: 'jrp 10/17/2004 12:22' prior: 0! - I am an SUnit Test of BlockContext and its supertype ContextPart. See also MethodContextTest. - - My fixtures are: - aBlockContext - just some trivial block, i.e., [100@100 corner: 200@200]. - - NOTES ABOUT AUTOMATING USER INPUTS - - When executing non-interactive programs you will inevitably run into programs (like SqueakMap or Monticello installation packages -- and other programs, to be fair) that require user input during their execution and these sort of problems shoot the whole non-interactiveness of your enclosing program. - - BlockContext helper methods have been made available and tests of these helpers are provided in this class to demonstrate that it can intercept PopUpMenu and FillInTheBlankMorph requests for user interaction. Of course, PopUpMenu and FillInTheBlankMorph were modified to first signal a ProvideAnswerNotification and if someone handles that (e.g. the enclosing block) then the user interaction will be circumvented and the provided answer of the enclosing block will be used. The basic syntax looks like: - - [self confirm: 'Install spyware?'] valueSupplyingAnswer: #('Install spyware?' false) - - There a few variants on this theme making it easy to provide a literal list of answers for the block so that you can handle a bunch of questions in a block with appropriate answers. - - Additionally, it is possible to suppress Object>>inform: modal dialog boxes as these get in the way of automating anything. After applying this changeset you should be able to tryout the following code snippets to see the variants on this theme that are available. - - Examples: - - So you don't need any introduction here -- this one works like usual. - [self inform: 'hello'. #done] value. - - Now let's suppress all inform: messages. - [self inform: 'hello'; inform: 'there'. #done] valueSuppressingAllMessages. - - Here we can just suppress a single inform: message. - [self inform: 'hi'; inform: 'there'. #done] valueSuppressingMessages: #('there') - - Here you see how you can suppress a list of messages. - [self inform: 'hi'; inform: 'there'; inform: 'bill'. #done] valueSuppressingMessages: #('hi' 'there') - - Enough about inform:, let's look at confirm:. As you see this one works as expected. - [self confirm: 'You like Squeak?'] value - - Let's supply answers to one of the questions -- check out the return value. - [{self confirm: 'You like Smalltalk?'. self confirm: 'You like Squeak?'}] - valueSupplyingAnswer: #('You like Smalltalk?' true) - - Here we supply answers using only substrings of the questions (for simplicity). - [{self confirm: 'You like Squeak?'. self confirm: 'You like MVC?'}] - valueSupplyingAnswers: #( ('Squeak' true) ('MVC' false) ) - - This time let's answer all questions exactly the same way. - [{self confirm: 'You like Squeak?'. self confirm: 'You like Morphic?'}] - valueSupplyingAnswer: true - - And, of course, we can answer FillInTheBlank questions in the same manner. - [FillInTheBlank request: 'What day is it?'] - valueSupplyingAnswer: 'the first day of the rest of your life' - - We can also return whatever the initialAnswer of the FillInTheBlank was by using the #default answer. - [FillInTheBlank request: 'What day is it?' initialAnswer: DateAndTime now dayOfWeekName] - valueSupplyingAnswer: #default - - Finally, you can also do regex matches on any of the question text (or inform text) (should you have VB-Regex enhancements in your image). - [FillInTheBlank request: 'What day is it?'] - valueSupplyingAnswers: { {'What day.*\?'. DateAndTime now dayOfWeekName} }! Item was removed: - ----- Method: BlockContextTest>>testSuppressInform (in category 'tests') ----- - testSuppressInform - - self should: [[nil inform: 'Should not see this message or this test failed!!'] valueSuppressingAllMessages isNil]! Item was removed: - ----- Method: BlockContextTest>>setUp (in category 'setup') ----- - setUp - super setUp. - aBlockContext := [100@100 corner: 200@200]. - contextOfaBlockContext := thisContext.! Item was removed: - ----- Method: BlockContextTest>>testTallyMethods (in category 'tests') ----- - testTallyMethods - self assert: (ContextPart tallyMethods: aBlockContext) size = 3.! Item was removed: - ----- Method: BlockContextTest>>testValueWithPossibleArgs (in category 'tests - evaluating') ----- - testValueWithPossibleArgs - | block blockWithArg blockWith2Arg | - - block := [1]. - blockWithArg := [:arg | arg]. - blockWith2Arg := [:arg1 :arg2 | {arg1. arg2}]. - - self assert: (block valueWithPossibleArgs: #()) = 1. - self assert: (block valueWithPossibleArgs: #(1)) = 1. - - self assert: (blockWithArg valueWithPossibleArgs: #()) = nil. - self assert: (blockWithArg valueWithPossibleArgs: #(1)) = 1. - self assert: (blockWithArg valueWithPossibleArgs: #(1 2)) = 1. - - self assert: (blockWith2Arg valueWithPossibleArgs: #()) = {nil .nil}. - self assert: (blockWith2Arg valueWithPossibleArgs: #(1)) = {1 . nil}. - self assert: (blockWith2Arg valueWithPossibleArgs: #(1 2)) = #(1 2). - self assert: (blockWith2Arg valueWithPossibleArgs: #(1 2 3)) = #(1 2). - - - ! Item was removed: - ----- Method: BlockContextTest>>testValueWithExitContinue (in category 'tests - evaluating') ----- - testValueWithExitContinue - - | val last | - val := 0. - - 1 to: 10 do: [ :i | - [ :continue | - i = 4 ifTrue: [continue value]. - val := val + 1. - last := i - ] valueWithExit. - ]. - - self assert: val = 9. - self assert: last = 10. ! Item was removed: - ----- Method: BlockContextTest>>testSupplySeveralAnswersToSeveralQuestions (in category 'tests') ----- - testSupplySeveralAnswersToSeveralQuestions - - self should: [#(false true) = ([{self confirm: 'One'. self confirm: 'Two'}] - valueSupplyingAnswers: #( ('One' false) ('Two' true) ))]. - - self should: [#(true false) = ([{self confirm: 'One'. self confirm: 'Two'}] - valueSupplyingAnswers: #( ('One' true) ('Two' false) ))]! Item was removed: - ----- Method: BlockContextTest>>testTrace (in category 'tests') ----- - testTrace - self assert: (ContextPart trace: aBlockContext) class = Rectangle.! Item was removed: - ----- Method: BlockContextTest>>testValueWithExitBreak (in category 'tests - evaluating') ----- - testValueWithExitBreak - - | val | - - [ :break | - 1 to: 10 do: [ :i | - val := i. - i = 4 ifTrue: [break value]. - ] - ] valueWithExit. - - self assert: val = 4.! Item was removed: - ----- Method: BlockContextTest>>testSupplyAnswerUsingOnlySubstringOfQuestion (in category 'tests') ----- - testSupplyAnswerUsingOnlySubstringOfQuestion - - self should: [false = ([self confirm: 'You like Smalltalk?'] - valueSupplyingAnswer: #('like' false))]! Item was removed: - ----- Method: BlockContextTest>>testSupplySpecificAnswerToQuestion (in category 'tests') ----- - testSupplySpecificAnswerToQuestion - - self should: [false = ([self confirm: 'You like Smalltalk?'] - valueSupplyingAnswer: #('You like Smalltalk?' false))]! Item was removed: - ----- Method: BlockContextTest>>testFindContextSuchThat (in category 'tests') ----- - testFindContextSuchThat - self assert: (aBlockContext findContextSuchThat: [:each| true]) printString = aBlockContext printString. - self assert: (aBlockContext hasContext: aBlockContext). ! Item was removed: - ----- Method: BlockContextTest>>testNoArguments (in category 'tests') ----- - testNoArguments - [10 - timesRepeat: [:arg | 1 + 2]] - ifError: [:err :rcvr | self deny: err = 'This block requires 1 arguments.']. - [10 - timesRepeat: [:arg1 :arg2 | 1 + 2]] - ifError: [:err :rcvr | self deny: err = 'This block requires 2 arguments.'] ! Item was removed: - ----- Method: BlockContextTest>>testBlockIsBottomContext (in category 'tests') ----- - testBlockIsBottomContext - self should: [aBlockContext client ] raise: Error. "block's sender is nil, a block has no client" - self assert: aBlockContext bottomContext = aBlockContext. - self assert: aBlockContext secondFromBottom isNil.! Item was removed: - ----- Method: BlockContextTest>>testValueWithArguments (in category 'tests - evaluating') ----- - testValueWithArguments - self - should: [aBlockContext - valueWithArguments: #(1 )] - raise: Error. - self - shouldnt: [aBlockContext - valueWithArguments: #()] - raise: Error. - [aBlockContext - valueWithArguments: #(1 )] - ifError: [:err :rcvr | self assert: err = 'Error: This block accepts 0 arguments, but was called with 1.']. - [[:i | 3 + 4] - valueWithArguments: #(1 2)] - ifError: [:err :rcvr | self assert: err = 'Error: This block accepts 1 argument, but was called with 2.']!

1 0

← Newer
1
2
3
4
5
6
7
...
30
Older →

Jump to page: