Squeak-dev June 2015

squeak-dev@lists.squeakfoundation.org

35 participants
162 discussions

Squeak 4.6: Traits-ul.305.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of Traits to project Squeak 4.6: http://source.squeak.org/squeak46/Traits-ul.305.mcz ==================== Summary ==================== Name: Traits-ul.305 Author: ul Time: 26 April 2015, 5:11:03.366 pm UUID: 34df02d0-c86a-4038-a909-e1d332374322 Ancestors: Traits-mt.304 - cache the source files during recompilation ==================== Snapshot ==================== SystemOrganization addCategory: #'Traits-Composition'! SystemOrganization addCategory: #'Traits-Kernel'! ----- Method: CompiledMethod class>>conflictMarker (in category '*Traits-constants') ----- conflictMarker ^ #traitConflict! ----- Method: CompiledMethod class>>explicitRequirementMarker (in category '*Traits-constants') ----- explicitRequirementMarker ^ #explicitRequirement! ----- Method: CompiledMethod class>>implicitRequirementMarker (in category '*Traits-constants') ----- implicitRequirementMarker ^ #requirement! ----- Method: CompiledMethod>>isConflict (in category '*Traits-testing') ----- isConflict ^ self markerOrNil == self class conflictMarker! ----- Method: CompiledMethod>>isExplicitlyRequired (in category '*Traits-testing') ----- isExplicitlyRequired ^ self isExplicitlyRequired: self markerOrNil! ----- Method: CompiledMethod>>isExplicitlyRequired: (in category '*Traits-testing') ----- isExplicitlyRequired: marker ^ marker == self class explicitRequirementMarker! ----- Method: CompiledMethod>>isImplicitlyRequired: (in category '*Traits-testing') ----- isImplicitlyRequired: marker ^ marker == self class implicitRequirementMarker! ----- Method: CompiledMethod>>isProvided (in category '*Traits-testing') ----- isProvided ^ self isProvided: self markerOrNil! ----- Method: CompiledMethod>>isProvided: (in category '*Traits-testing') ----- isProvided: marker marker ifNil: [^ true]. ^ (self isRequired: marker) not and: [(self isDisabled: marker) not]! ----- Method: CompiledMethod>>isRequired (in category '*Traits-testing') ----- isRequired ^ self isRequired: self markerOrNil! ----- Method: CompiledMethod>>isRequired: (in category '*Traits-testing') ----- isRequired: marker marker ifNil: [^ false]. (self isImplicitlyRequired: marker) ifTrue: [^ true]. (self isExplicitlyRequired: marker) ifTrue: [^ true]. (self isSubclassResponsibility: marker) ifTrue: [^ true]. ^ false! ----- Method: CompiledMethod>>isTraitMethod (in category '*Traits-testing') ----- isTraitMethod ^ self originalTraitMethod notNil! ----- Method: CompiledMethod>>originalTraitMethod (in category '*Traits-NanoKernel') ----- originalTraitMethod "Remember the original trait method for the receiver." ^self properties originalTraitMethod! ----- Method: CompiledMethod>>originalTraitMethod: (in category '*Traits-NanoKernel') ----- originalTraitMethod: aCompiledMethod "Remember the original trait method for the receiver." | methodState | methodState := TraitMethodState newFrom: self properties. methodState originalTraitMethod: aCompiledMethod. self penultimateLiteral: methodState.! ----- Method: CompiledMethod>>originalTraitOrClass (in category '*Traits-NanoKernel') ----- originalTraitOrClass "The original trait for this method" ^self properties originalTraitOrClass! ----- Method: CompiledMethod>>sameTraitCodeAs: (in category '*Traits-NanoKernel') ----- sameTraitCodeAs: method "Answer whether the receiver implements the same code as the argument, method. Does not look at properties/pragmas since they do not affect the resulting code." | numLits | (method isKindOf: CompiledMethod) ifFalse: [^false]. self methodHome == method methodHome ifFalse:[^false]. (self properties analogousCodeTo: method properties) ifFalse:[^false]. self size = method size ifFalse: [^false]. self header = method header ifFalse: [^false]. self initialPC to: self endPC do:[:i | (self at: i) = (method at: i) ifFalse: [^false]]. (numLits := self numLiterals) ~= method numLiterals ifTrue: [^false]. 1 to: numLits-2 do:[:i| | lit1 lit2 | lit1 := self literalAt: i. lit2 := method literalAt: i. (lit1 == lit2 or: [lit1 literalEqual: lit2]) ifFalse: [ (i = 1 and: [#(117 120) includes: self primitive]) ifTrue: [ lit1 isArray ifTrue:[ (lit2 isArray and: [lit1 allButLast = lit2 allButLast]) ifFalse:[^false] ] ifFalse: "ExternalLibraryFunction" [(lit1 analogousCodeTo: lit2) ifFalse:[^false]]. ] ifFalse:[ "any other discrepancy is a failure"^ false]]]. ^true! ----- Method: AdditionalMethodState>>originalTraitMethod (in category '*Traits-NanoKernel') ----- originalTraitMethod "The original method from the trait. Only available in TraitMethodState." ^nil! ----- Method: AdditionalMethodState>>originalTraitOrClass (in category '*Traits-NanoKernel') ----- originalTraitOrClass "The original trait for this method" ^method methodClass! AdditionalMethodState variableSubclass: #TraitMethodState instanceVariableNames: 'originalTraitMethod' classVariableNames: '' poolDictionaries: '' category: 'Traits-Kernel'! !TraitMethodState commentStamp: 'ar 12/29/2009 18:13' prior: 0! Additional method state for trait provided methods.! ----- Method: TraitMethodState>>methodHome (in category 'accessing') ----- methodHome "The behavior (trait/class) this method was originally defined in. Derived from the originalTraitMethod if any." ^originalTraitMethod ifNil:[super methodHome] ifNotNil:[:m| m methodHome]! ----- Method: TraitMethodState>>originalTraitMethod (in category 'accessing') ----- originalTraitMethod "The original method from the trait" ^originalTraitMethod! ----- Method: TraitMethodState>>originalTraitMethod: (in category 'accessing') ----- originalTraitMethod: aCompiledMethod "The original method from the trait" originalTraitMethod := aCompiledMethod! ----- Method: TraitMethodState>>originalTraitOrClass (in category 'accessing') ----- originalTraitOrClass "The original trait for this method" ^originalTraitMethod originalTraitOrClass! ----- Method: MethodReference>>isTraitMethod (in category '*Traits-testing') ----- isTraitMethod ^ self compiledMethod isTraitMethod! ----- Method: ClassDescription class>>allTraitsDo: (in category '*Traits') ----- allTraitsDo: aBlock "Evaluate aBlock with all the instance and class traits present in the system" TraitImpl ifNotNil:[TraitImpl allTraitsDo: aBlock].! ----- Method: ClassDescription class>>newTraitComposition (in category '*Traits') ----- newTraitComposition "Answer a new trait composition. If no current trait implementation is installed, return an empty array" ^TraitImpl ifNil:[#()] ifNotNil:[TraitImpl newTraitComposition].! ----- Method: ClassDescription class>>newTraitNamed:uses:category: (in category '*Traits') ----- newTraitNamed: aSymbol uses: aTraitCompositionOrCollection category: aString "Creates a new trait. If no current trait implementation is installed, raise an error." ^TraitImpl ifNil:[self error: 'Traits are not installed'] ifNotNil:[TraitImpl newTraitNamed: aSymbol uses: aTraitCompositionOrCollection category: aString]! ----- Method: ClassDescription class>>newTraitTemplateIn: (in category '*Traits') ----- newTraitTemplateIn: categoryString ^TraitImpl ifNil:[''] ifNotNil:[TraitImpl newTemplateIn: categoryString].! ----- Method: ClassDescription class>>traitImpl (in category '*Traits') ----- traitImpl "Answer the default implementor of traits" ^TraitImpl! ----- Method: ClassDescription class>>traitImpl: (in category '*Traits') ----- traitImpl: aTraitClass "Make the given trait class the default implementor of traits" TraitImpl := aTraitClass.! ----- Method: ClassDescription>>allTraits (in category '*Traits-NanoKernel') ----- allTraits "Answer all the traits that are used by myself without their transformations" ^self traitComposition isEmpty ifTrue:[#()] ifFalse:[self traitComposition allTraits].! ----- Method: ClassDescription>>assembleTraitMethodsFrom: (in category '*Traits-NanoKernel') ----- assembleTraitMethodsFrom: aTraitComposition "Assemble the resulting methods for installing the given trait composition. Returns a Dictionary instead of a MethodDictionary for speed (MDs grow by #become:)" | methods | methods := Dictionary new. "Stick in the local methods first, since this avoids generating conflict methods unnecessarily" self selectorsAndMethodsDo:[:sel :newMethod| (self isLocalMethod: newMethod) ifTrue:[methods at: sel put:newMethod]]. "Now assemble the traits methods" aTraitComposition do:[:trait| trait selectorsAndMethodsDo:[:sel :newMethod| | oldMethod | oldMethod := methods at: sel ifAbsentPut:[newMethod]. newMethod == oldMethod ifFalse:["a conflict" (self isLocalMethod: oldMethod) ifFalse:[ methods at: sel put: (self resolveTraitsConflict: sel from: oldMethod to: newMethod)]]]]. ^methods! ----- Method: ClassDescription>>basicRemoveSelector: (in category '*Traits-NanoKernel') ----- basicRemoveSelector: aSelector "Remove the message whose selector is given from the method dictionary of the receiver, if it is there. Update the trait composition." | oldMethod | oldMethod := super basicRemoveSelector: aSelector. oldMethod ifNotNil:[self updateTraits]. ^oldMethod! ----- Method: ClassDescription>>classify:under:from:trait: (in category '*Traits-NanoKernel') ----- classify: selector under: heading from: category trait: aTrait "Update the organization for a trait. the dumb, unoptimized version" self updateTraits.! ----- Method: ClassDescription>>hasTraitComposition (in category '*Traits-NanoKernel') ----- hasTraitComposition ^self traitComposition notEmpty! ----- Method: ClassDescription>>includesLocalSelector: (in category '*Traits-NanoKernel') ----- includesLocalSelector: selector ^(self compiledMethodAt: selector ifAbsent:[^false]) methodHome == self! ----- Method: ClassDescription>>includesTrait: (in category '*Traits-NanoKernel') ----- includesTrait: aTrait ^self traitComposition anySatisfy:[:each| each includesTrait: aTrait]! ----- Method: ClassDescription>>installTraitMethodDict: (in category '*Traits-NanoKernel') ----- installTraitMethodDict: methods "After having assembled the trait composition, install its methods." | oldCategories removals | "Apply the changes. We first add the new or changed methods." oldCategories := Set new. methods keysAndValuesDo:[:sel :newMethod| | oldMethod | oldMethod := self compiledMethodAt: sel ifAbsent:[nil]. oldMethod == newMethod ifFalse:[ self traitAddSelector: sel withMethod: newMethod. (self organization categoryOfElement: sel) ifNotNil:[:cat| oldCategories add: cat]. self organization classify: sel under: (newMethod methodHome organization categoryOfElement: newMethod selector)]]. "Now remove the old or obsoleted ones" removals := OrderedCollection new. self selectorsDo:[:sel| (methods includesKey: sel) ifFalse:[removals add: sel]]. removals do:[:sel| self traitRemoveSelector: sel]. "Clean out empty categories" oldCategories do:[:cat| (self organization isEmptyCategoryNamed: cat) ifTrue:[self organization removeCategory: cat]]. ! ----- Method: ClassDescription>>installTraitsFrom: (in category '*Traits-NanoKernel') ----- installTraitsFrom: aTraitComposition "Install the traits from the given composition. This method implements the core composition method - all others are just optimizations for particular cases. Consequently, the optimized versions can always fall back to this method when things get too hairy." | allTraits methods | (self traitComposition isEmpty and: [aTraitComposition isEmpty]) ifTrue: [^self]. "Check for cycles" allTraits := aTraitComposition gather: [:t | t allTraits copyWith: t]. (allTraits includes: self) ifTrue:[^self error: 'Cyclic trait definition detected']. self traitComposition: aTraitComposition. methods := self assembleTraitMethodsFrom: aTraitComposition. self installTraitMethodDict: methods. self isMeta ifFalse:[self classSide updateTraitsFrom: aTraitComposition]. ! ----- Method: ClassDescription>>isAliasSelector: (in category '*Traits-NanoKernel') ----- isAliasSelector: aSymbol "Return true if the selector aSymbol is an alias defined in my or in another composition somewhere deeper in the tree of traits compositions." ^(self includesLocalSelector: aSymbol) not and: [self hasTraitComposition and: [self traitComposition isAliasSelector: aSymbol]]! ----- Method: ClassDescription>>isLocalAliasSelector: (in category '*Traits-NanoKernel') ----- isLocalAliasSelector: aSymbol "Return true if the selector aSymbol is an alias defined in my or in another composition somewhere deeper in the tree of traits compositions." ^(self includesLocalSelector: aSymbol) not and: [self hasTraitComposition and: [self traitComposition isLocalAliasSelector: aSymbol]]! ----- Method: ClassDescription>>isLocalMethod: (in category '*Traits-NanoKernel') ----- isLocalMethod: aCompiledMethod "Answer true if the method is a local method, e.g., defined in the receiver instead of a trait." ^aCompiledMethod methodHome == self! ----- Method: ClassDescription>>localSelectors (in category '*Traits-NanoKernel') ----- localSelectors ^self selectors select:[:sel| self includesLocalSelector: sel]! ----- Method: ClassDescription>>recompile:from: (in category '*Traits-NanoKernel') ----- recompile: selector from: oldClass "Preserve the originalTraitMethod (if any) after recompiling a selector" | oldMethod | oldMethod := oldClass compiledMethodAt: selector. super recompile: selector from: oldClass. oldMethod originalTraitMethod ifNotNil:[:traitMethod| (self compiledMethodAt: selector) originalTraitMethod: traitMethod. ]. ! ----- Method: ClassDescription>>replaceSelector:withAlias:in: (in category '*Traits-NanoKernel') ----- replaceSelector: originalSelector withAlias: aliasSelector in: source "replaces originalSelector with aliasSelector in in given source code" | oldKeywords newKeywords args selectorWithArgs s | oldKeywords := originalSelector keywords. newKeywords := aliasSelector keywords. oldKeywords size = newKeywords size ifFalse:[self error: 'Keyword mismatch']. args := self newParser parseParameterNames: source asString. selectorWithArgs := String streamContents: [:stream | newKeywords keysAndValuesDo: [:index :keyword | stream nextPutAll: keyword. stream space. args size >= index ifTrue: [ stream nextPutAll: (args at: index); space]]]. s := source asString readStream. oldKeywords do: [ :each | s match: each ]. args isEmpty ifFalse: [ s match: args last ]. ^selectorWithArgs withBlanksTrimmed asText , s upToEnd ! ----- Method: ClassDescription>>resolveTraitsConflict:from:to: (in category '*Traits-NanoKernel') ----- resolveTraitsConflict: aSelector from: oldMethod to: newMethod "Resolve a traits conflict. Rules: - If one method is required the other one wins - Otherwise we compile a traits conflict " | marker selector | oldMethod methodHome == newMethod methodHome ifTrue:[^oldMethod]. marker := oldMethod markerOrNil. (#(requirement explicitRequirement subclassResponsibility shouldNotImplement) includes: marker) ifTrue:[^newMethod]. marker := newMethod markerOrNil. (#(requirement explicitRequirement subclassResponsibility shouldNotImplement) includes: marker) ifTrue:[^oldMethod]. "Create a conflict marker" selector := #(conflict conflict: conflict:with: conflict:with:with: conflict:with:with:with: conflict:with:with:with:with: conflict:with:with:with:with:with: conflict:with:with:with:with:with:with: conflict:with:with:with:with:with:with:with:) at: oldMethod numArgs+1. ^TraitDescription class compiledMethodAt: selector.! ----- Method: ClassDescription>>setTraitComposition: (in category '*Traits-NanoKernel') ----- setTraitComposition: aTraitComposition "OBSOLETE. Use Class uses: aTraitComposition instead." ^self uses: aTraitComposition ! ----- Method: ClassDescription>>setTraitCompositionFrom: (in category '*Traits-NanoKernel') ----- setTraitCompositionFrom: aTraitComposition "OBSOLETE. Use Class uses: aTraitComposition instead." ^self uses: aTraitComposition ! ----- Method: ClassDescription>>traitAddSelector:withMethod: (in category '*Traits-NanoKernel') ----- traitAddSelector: selector withMethod: traitMethod "Add a method inherited from a trait. Recompiles to avoid sharing and implement aliasing." | oldMethod source methodNode newMethod originalSelector | oldMethod := self compiledMethodAt: selector ifAbsent:[nil]. oldMethod ifNotNil:[ "The following is an important optimization as it prevents exponential growth in recompilation. If T1 is used by T2 and T2 by T3 then (without this optimization) any change in T1 would cause all methods in T2 to be recompiled and each recompilation of a method in T2 would cause T3 to be fully recompiled. The test eliminates all such situations." (oldMethod sameTraitCodeAs: traitMethod) ifTrue:[^oldMethod]. ]. originalSelector := traitMethod selector. source := traitMethod methodClass sourceCodeAt: originalSelector. originalSelector == selector ifFalse:[ "Replace source selectors for aliases" source := self replaceSelector: originalSelector withAlias: selector in: source. ]. methodNode := self newCompiler compile: source in: self notifying: nil ifFail:[^nil]. newMethod := methodNode generate: (self defaultMethodTrailerIfLogSource: true). newMethod putSource: source fromParseNode: methodNode inFile: 2 withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Trait method'; cr]. newMethod originalTraitMethod: traitMethod. ^super addSelectorSilently: selector withMethod: newMethod.! ----- Method: ClassDescription>>traitComposition (in category '*Traits-NanoKernel') ----- traitComposition "Answer my trait composition" ^self organization traitComposition! ----- Method: ClassDescription>>traitComposition: (in category '*Traits-NanoKernel') ----- traitComposition: aTraitComposition "Install my trait composition" self traitComposition do:[:tc| tc removeTraitUser: self]. aTraitComposition isEmptyOrNil ifTrue:[ self organization isTraitOrganizer ifTrue:[self organization: (ClassOrganizer newFrom: self organization)]. ] ifFalse:[ self organization isTraitOrganizer ifFalse:[self organization: (TraitOrganizer newFrom: self organization)]. self organization traitComposition: aTraitComposition. aTraitComposition do:[:tc| tc addTraitUser: self]. ]. ! ----- Method: ClassDescription>>traitCompositionString (in category '*Traits-NanoKernel') ----- traitCompositionString "Answer the trait composition string for the receiver" ^self traitComposition isEmpty ifTrue:['{}'] ifFalse:[self traitComposition asString].! ----- Method: ClassDescription>>traitRemoveSelector: (in category '*Traits-NanoKernel') ----- traitRemoveSelector: selector "Remove the message whose selector is given from the method dictionary of the receiver, if it is there. Answer nil otherwise." | priorMethod priorProtocol | priorMethod := self compiledMethodAt: selector ifAbsent: [^ nil]. priorProtocol := self whichCategoryIncludesSelector: selector. SystemChangeNotifier uniqueInstance doSilently: [ self organization removeElement: selector]. super basicRemoveSelector: selector. SystemChangeNotifier uniqueInstance methodRemoved: priorMethod selector: selector inProtocol: priorProtocol class: self. (self organization isEmptyCategoryNamed: priorProtocol) ifTrue:[self organization removeCategory: priorProtocol]. ! ----- Method: ClassDescription>>traits (in category '*Traits-NanoKernel') ----- traits "Answer an array of my traits" ^self traitComposition asArray collect:[:composed| composed trait]! ----- Method: ClassDescription>>updateTraits (in category '*Traits-NanoKernel') ----- updateTraits "Recompute my local traits composition" self installTraitsFrom: self traitComposition. ! ----- Method: ClassDescription>>updateTraitsFrom: (in category '*Traits-NanoKernel') ----- updateTraitsFrom: instanceTraits "ClassTrait/Metaclass only. Update me from the given instance traits" | map newTraits | self isMeta ifFalse:[self error: 'This is a metaclass operation']. map := Dictionary new. self traitComposition do:[:composed| map at: composed trait put: composed]. newTraits := (instanceTraits collect:[:composed| | trait | trait := composed trait classTrait. map at: trait ifAbsent:[trait]] ), (self traitComposition select:[:comp| comp trait isBaseTrait]). self installTraitsFrom: newTraits! ----- Method: ClassDescription>>users (in category '*Traits-NanoKernel') ----- users ^#()! ----- Method: ClassDescription>>uses: (in category '*Traits-NanoKernel') ----- uses: aTraitComposition self installTraitsFrom: aTraitComposition asTraitComposition. ! ClassDescription subclass: #TraitBehavior instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Traits-Kernel'! !TraitBehavior commentStamp: 'ar 12/29/2009 18:15' prior: 0! Stub class for backward compatibility. Allows past extension methods in TraitBehavior to continue to work.! TraitBehavior subclass: #TraitDescription instanceVariableNames: 'users' classVariableNames: '' poolDictionaries: '' category: 'Traits-Kernel'! !TraitDescription commentStamp: 'ar 12/29/2009 18:15' prior: 0! TraitDescription combines common behavior for both (instance) traits and (meta) class traits.! TraitDescription subclass: #ClassTrait instanceVariableNames: 'baseTrait' classVariableNames: '' poolDictionaries: '' category: 'Traits-Kernel'! !ClassTrait commentStamp: 'ar 12/29/2009 18:16' prior: 0! The class of some trait. Just like the Class - Metaclass relationship.! ----- Method: ClassTrait class>>for: (in category 'instance creation') ----- for: baseTrait ^self new baseTrait: baseTrait! ----- Method: ClassTrait>>asMCDefinition (in category 'monticello') ----- asMCDefinition ^Smalltalk at: #MCClassTraitDefinition ifPresent:[:aClass| aClass baseTraitName: self baseTrait name classTraitComposition: self traitCompositionString ].! ----- Method: ClassTrait>>baseTrait (in category 'accessing') ----- baseTrait ^baseTrait! ----- Method: ClassTrait>>baseTrait: (in category 'accessing') ----- baseTrait: aTrait baseTrait ifNotNil:[self error: 'Already initialized']. baseTrait := aTrait.! ----- Method: ClassTrait>>bindingOf: (in category 'compiling') ----- bindingOf: varName "Answer the binding of some variable resolved in the scope of the receiver" ^baseTrait bindingOf: varName! ----- Method: ClassTrait>>category (in category 'accessing') ----- category "Answer the category used for classifying this ClassTrait. The category is shared between a Trait and its associated ClassTrait." ^baseTrait category! ----- Method: ClassTrait>>definition (in category 'accessing') ----- definition ^String streamContents: [:stream | stream nextPutAll: self name. stream cr; tab; nextPutAll: 'uses: '; nextPutAll: self traitComposition asString. ].! ----- Method: ClassTrait>>instanceSide (in category 'accessing') ----- instanceSide ^self baseTrait! ----- Method: ClassTrait>>isClassTrait (in category 'testing') ----- isClassTrait ^true! ----- Method: ClassTrait>>isMeta (in category 'testing') ----- isMeta ^true! ----- Method: ClassTrait>>isObsolete (in category 'testing') ----- isObsolete ^baseTrait == nil or:[baseTrait isObsolete]! ----- Method: ClassTrait>>name (in category 'accessing') ----- name ^baseTrait name, ' classTrait'! ----- Method: ClassTrait>>soleInstance (in category 'accessing') ----- soleInstance ^baseTrait! ----- Method: ClassTrait>>theMetaClass (in category 'accessing') ----- theMetaClass ^self! ----- Method: ClassTrait>>theNonMetaClass (in category 'accessing') ----- theNonMetaClass "Sent to a class or metaclass, always return the class" ^baseTrait! ----- Method: ClassTrait>>uses: (in category 'initialize') ----- uses: aTraitComposition | newTraits copyOfOldTrait | copyOfOldTrait := self shallowCopy. newTraits := aTraitComposition asTraitComposition. newTraits traitsDo:[:t| (t isBaseTrait and:[t classSide hasMethods]) ifTrue:[self error: 'Cannot add: ', t]. (t isClassTrait and:[(baseTrait includesTrait: t baseTrait) not]) ifTrue:[self error: 'Cannot add: ', t]. ]. self installTraitsFrom: newTraits. SystemChangeNotifier uniqueInstance traitDefinitionChangedFrom: copyOfOldTrait to: self.! TraitDescription subclass: #Trait instanceVariableNames: 'name environment classTrait category' classVariableNames: '' poolDictionaries: '' category: 'Traits-Kernel'! !Trait commentStamp: 'ar 12/29/2009 18:16' prior: 0! Defines a trait in the system. Like Class, I concretize my superclass by providing instance variables for the name and the environment.! ----- Method: Trait class>>allTraitsDo: (in category 'public') ----- allTraitsDo: aBlock "Evaluate aBlock with all the instance and class traits present in the system" Smalltalk allTraitsDo: [ :aTrait | aBlock value: aTrait instanceSide; value: aTrait classSide ]! ----- Method: Trait class>>convertClassToTrait: (in category 'load-unload') ----- convertClassToTrait: aClass "Convert the given class to a trait" | aTrait | "Move the class out of the way" aClass environment removeKey: aClass name. "Create the trait in its place" aTrait := Trait named: aClass name uses: {} category: aClass category. aClass organization commentRemoteStr ifNotNil:[ aTrait classComment: aClass organization classComment stamp: aClass organization commentStamp]. aClass selectorsAndMethodsDo:[:sel :meth| aTrait compile: (aClass sourceCodeAt: sel) classified: (aClass organization categoryOfElement: sel) withStamp: (aClass compiledMethodAt: sel) timeStamp notifying: nil]. aClass classSide selectorsAndMethodsDo:[:sel :meth| aTrait classSide compile: (aClass classSide sourceCodeAt: sel) classified: (aClass classSide organization categoryOfElement: sel) withStamp: (aClass classSide compiledMethodAt: sel) timeStamp notifying: nil]. aClass obsolete. ^aTrait ! ----- Method: Trait class>>convertTraitToClass: (in category 'load-unload') ----- convertTraitToClass: aTrait "Convert the given trait to a class" | aClass | "Move the trait out of the way" aTrait environment removeKey: aTrait name. "Create the class in its place" aClass := Object subclass: aTrait name instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: aTrait category. aTrait organization commentRemoteStr ifNotNil:[ aClass classComment: aTrait organization classComment stamp: aTrait organization commentStamp]. aTrait selectorsAndMethodsDo:[:sel :meth| aClass compile: (aTrait sourceCodeAt: sel) classified: (aTrait organization categoryOfElement: sel) withStamp: (aTrait compiledMethodAt: sel) timeStamp notifying: nil]. aTrait classSide selectorsAndMethodsDo:[:sel :meth| aClass classSide compile: (aTrait classSide sourceCodeAt: sel) classified: (aTrait classSide organization categoryOfElement: sel) withStamp: (aTrait classSide compiledMethodAt: sel) timeStamp notifying: nil]. aTrait obsolete. ^aClass ! ----- Method: Trait class>>flattenTraitMethodsInClass: (in category 'load-unload') ----- flattenTraitMethodsInClass: aClass "Flatten all the trait methods in the given class" (aClass isTrait or:[aClass hasTraitComposition]) ifFalse:[^self]. self storeTraitInfoInClass: aClass. aClass selectorsAndMethodsDo:[:sel :meth| | oldClass | (aClass includesLocalSelector: sel) ifFalse:[ oldClass := meth methodHome. aClass compile: (aClass sourceCodeAt: sel) classified: (aClass organization categoryOfElement: sel) withStamp: (oldClass compiledMethodAt: sel ifAbsent:[meth]) timeStamp notifying: nil]]. aClass traitComposition: #().! ----- Method: Trait class>>initialize (in category 'load-unload') ----- initialize "Install after loading" self install.! ----- Method: Trait class>>install (in category 'load-unload') ----- install "Make me the default Trait implementation" ClassDescription traitImpl: self. "And restore any previously flattened traits" self restoreAllTraits. ! ----- Method: Trait class>>named:uses:category: (in category 'public') ----- named: aSymbol uses: aTraitCompositionOrCollection category: aString "Dispatch through ClassDescription for alternative implementations" ^ClassDescription newTraitNamed: aSymbol uses: aTraitCompositionOrCollection category: aString! ----- Method: Trait class>>named:uses:category:env: (in category 'instance creation') ----- named: aSymbol uses: aTraitComposition category: aString env: anEnvironment | trait oldTrait systemCategory | systemCategory := aString asSymbol. trait := anEnvironment at: aSymbol ifAbsent: [nil]. (trait == nil or:[trait isMemberOf: Trait]) ifFalse: [ ^self error: trait name , ' is not a Trait']. oldTrait := trait shallowCopy. trait ifNil:[trait := Trait new]. trait setName: aSymbol andRegisterInCategory: systemCategory environment: anEnvironment. trait uses: aTraitComposition. "... notify interested clients ..." oldTrait ifNil:[ SystemChangeNotifier uniqueInstance classAdded: trait inCategory: systemCategory. ] ifNotNil:[ SystemChangeNotifier uniqueInstance traitDefinitionChangedFrom: oldTrait to: trait. systemCategory = oldTrait category ifFalse:[ SystemChangeNotifier uniqueInstance class: trait recategorizedFrom: oldTrait category to: systemCategory]. ]. ^ trait! ----- Method: Trait class>>newTemplateIn: (in category 'public') ----- newTemplateIn: categoryString ^String streamContents: [:stream | stream nextPutAll: 'Trait named: #NameOfTrait'; cr; tab; nextPutAll: 'uses: {}'; cr; tab; nextPutAll: 'category: '; nextPut: $'; nextPutAll: categoryString; nextPut: $' ]! ----- Method: Trait class>>newTraitComposition (in category 'public') ----- newTraitComposition "Creates a new TraitComposition" ^TraitComposition new! ----- Method: Trait class>>newTraitNamed:uses:category: (in category 'public') ----- newTraitNamed: aSymbol uses: aTraitCompositionOrCollection category: aString "Creates a new trait." | env | env := self environment. ^self named: aSymbol uses: aTraitCompositionOrCollection category: aString env: env! ----- Method: Trait class>>removeAllTraits (in category 'load-unload') ----- removeAllTraits "Trait removeAllTraits" "Removes all traits currently in use. Preserves enough information so that traits can be recovered." | converted remain | converted := Set new. Smalltalk allClasses do:[:aClass| self flattenTraitMethodsInClass: aClass classSide. self flattenTraitMethodsInClass: aClass. converted add: aClass. ] displayingProgress: 'Flattening classes'. remain := Smalltalk allTraits asSet. (1 to: remain size) do:[:i| | trait | trait := remain detect:[:any| any users allSatisfy:[:aClass| converted includes: aClass]] ifNone:[self error: 'Cyclic traits detected']. remain remove: trait. self flattenTraitMethodsInClass: trait classSide. self flattenTraitMethodsInClass: trait. converted add: trait. ] displayingProgress: 'Flattening traits'. "Convert all traits to classes" Smalltalk allTraits do:[:trait| self convertTraitToClass: trait] displayingProgress:[:trait| 'Converting ', trait name]. ! ----- Method: Trait class>>restoreAllTraits (in category 'load-unload') ----- restoreAllTraits "Trait restoreAllTraits" "Restores traits that had been previously removed. This is the inverse operation to removeAllTraits." | classes | classes := Smalltalk allClasses select:[:aClass| aClass includesSelector: #traitInfo]. classes do:[:aClass| | method | method := aClass compiledMethodAt: #traitInfo. (method pragmaAt: #traitDefinition:) ifNotNil:[:pragma| pragma arguments first ifTrue:[self convertClassToTrait: aClass]]. ] displayingProgress:[:aClass| 'Creating trait ', aClass name]. classes := Smalltalk allClassesAndTraits select:[:aClass| (aClass includesSelector: #traitInfo) or:[aClass classSide includesSelector: #traitInfo]]. classes do:[:aClass| self restoreCompositionOf: aClass. self restoreCompositionOf: aClass classSide. ] displayingProgress:[:aClass| 'Updating ', aClass name]. ! ----- Method: Trait class>>restoreCompositionOf: (in category 'load-unload') ----- restoreCompositionOf: aClass "Restore the trait composition for the given class" | method requires composition | method := aClass compiledMethodAt: #traitInfo ifAbsent:[^self]. aClass removeSelector: #traitInfo. requires := (method pragmaAt: #traitRequires:) ifNil:[#()] ifNotNil:[:pragma| pragma arguments first]. (requires allSatisfy:[:tn| (Smalltalk at: tn ifAbsent:[nil]) isKindOf: Trait]) ifFalse:[^self inform: 'Cannot restore composition of ', aClass name]. composition := (method pragmaAt: #traitComposition:) ifNil:[^self] ifNotNil:[:pragma| Compiler evaluate: pragma arguments first]. aClass uses: composition. aClass traitComposition selectorsAndMethodsDo:[:sel :meth| | oldMethod newMethod | newMethod := meth methodHome compiledMethodAt: sel. oldMethod := aClass compiledMethodAt: sel ifAbsent:[newMethod]. oldMethod timeStamp = newMethod timeStamp ifTrue:[aClass removeSelector: sel]].! ----- Method: Trait class>>storeTraitInfoInClass: (in category 'load-unload') ----- storeTraitInfoInClass: aClass "Store trait information in the given class" | code | code := WriteStream on: (String new: 100). code nextPutAll: 'traitInfo "This method contains information to restore the trait structure for the receiver when traits are loaded or unloaded"'. aClass isTrait ifTrue:[ code crtab; nextPutAll: '"This class was originally a trait"'. code crtab; nextPutAll: '<traitDefinition: true>'. ]. aClass hasTraitComposition ifTrue:[ code crtab; nextPutAll: '"The trait composition for the receiver"'. code crtab; nextPutAll: '<traitComposition: ', aClass traitCompositionString storeString,'>'. code crtab; nextPutAll: '"The required traits for this trait"'. code crtab; nextPutAll: '<traitRequires: ', (aClass traits collect:[:t| t baseTrait name]),'>'. ]. aClass compile: code contents. ! ----- Method: Trait class>>unloadTraits (in category 'load-unload') ----- unloadTraits "Trait unloadTraits" Trait traitImpl == self ifTrue:[Trait traitImpl: nil]. self removeAllTraits. Behavior compileSilently: 'updateTraits' classified: 'accessing'. ClassDescription removeSelectorSilently: #updateTraits. ClassOrganizer organization classify: #traitComposition under: 'accessing'. (MCPackage named: 'Traits') unload. ClassOrganizer removeSelectorSilently: #traitComposition. Behavior removeSelectorSilently: #updateTraits. CurrentReadOnlySourceFiles cacheDuring: [ Compiler recompileAll ]! ----- Method: Trait>>asTraitComposition (in category 'converting') ----- asTraitComposition "Convert me into a trait composition" ^TraitComposition with: self! ----- Method: Trait>>baseTrait (in category 'accessing') ----- baseTrait ^self! ----- Method: Trait>>bindingOf: (in category 'compiling') ----- bindingOf: varName "Answer the binding of some variable resolved in the scope of the receiver" ^self environment bindingOf: varName asSymbol.! ----- Method: Trait>>category (in category 'accessing') ----- category "Answer the system organization category for the receiver. First check whether the category name stored in the ivar is still correct and only if this fails look it up (latter is much more expensive)" | result | category ifNotNilDo: [ :symbol | ((SystemOrganization listAtCategoryNamed: symbol) includes: self name) ifTrue: [ ^symbol ] ]. category := (result := SystemOrganization categoryOfElement: self name). ^result! ----- Method: Trait>>category: (in category 'accessing') ----- category: aString "Categorize the receiver under the system category, aString, removing it from any previous categorization." | oldCategory | oldCategory := category. aString isString ifTrue: [ category := aString asSymbol. SystemOrganization classify: self name under: category ] ifFalse: [self errorCategoryName]. SystemChangeNotifier uniqueInstance class: self recategorizedFrom: oldCategory to: category! ----- Method: Trait>>classTrait (in category 'accessing') ----- classTrait ^classTrait! ----- Method: Trait>>definition (in category 'initialize') ----- definition ^String streamContents: [:stream | stream nextPutAll: 'Trait named: '; store: self name. stream cr; tab; nextPutAll: 'uses: '; nextPutAll: self traitComposition asString. stream cr; tab; nextPutAll: 'category: '; store: self category asString].! ----- Method: Trait>>environment (in category 'accessing') ----- environment ^environment! ----- Method: Trait>>environment: (in category 'accessing') ----- environment: anObject environment := anObject! ----- Method: Trait>>fileOutOn:moveSource:toFile: (in category 'fileIn/Out') ----- fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex super fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex. self classSide hasMethods ifTrue:[ aFileStream cr; nextPutAll: '"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!!'; cr; cr. self classSide fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex].! ----- Method: Trait>>hasClassTrait (in category 'testing') ----- hasClassTrait ^true! ----- Method: Trait>>initialize (in category 'initialize') ----- initialize super initialize. classTrait := ClassTrait for: self.! ----- Method: Trait>>isBaseTrait (in category 'testing') ----- isBaseTrait ^true! ----- Method: Trait>>isObsolete (in category 'testing') ----- isObsolete "Return true if the receiver is obsolete." ^(self environment at: name ifAbsent: [nil]) ~~ self! ----- Method: Trait>>isValidTraitName: (in category 'initialize') ----- isValidTraitName: aSymbol ^(aSymbol isEmptyOrNil or: [aSymbol first isLetter not or: [aSymbol anySatisfy: [:character | character isAlphaNumeric not]]]) not! ----- Method: Trait>>name (in category 'accessing') ----- name ^name! ----- Method: Trait>>name: (in category 'accessing') ----- name: aSymbol name := aSymbol! ----- Method: Trait>>obsolete (in category 'initialize') ----- obsolete self name: ('AnObsolete' , self name) asSymbol. self classTrait obsolete. super obsolete! ----- Method: Trait>>removeFromSystem (in category 'initialize') ----- removeFromSystem self removeFromSystem: true! ----- Method: Trait>>removeFromSystem: (in category 'initialize') ----- removeFromSystem: logged self environment forgetClass: self logged: logged. self obsolete! ----- Method: Trait>>rename: (in category 'initialize') ----- rename: aString "The new name of the receiver is the argument, aString." | newName | (newName := aString asSymbol) ~= self name ifFalse: [^ self]. (self environment includesKey: newName) ifTrue: [^ self error: newName , ' already exists']. ((self environment undeclared includesKey: newName) and: [(self environment undeclared unreferencedKeys includes: newName) not]) ifTrue: [self inform: 'There are references to, ' , aString printString , ' from Undeclared. Check them after this change.']. self environment renameClass: self as: newName. name := newName! ----- Method: Trait>>setName:andRegisterInCategory:environment: (in category 'initialize') ----- setName: aSymbol andRegisterInCategory: categorySymbol environment: aSystemDictionary (self isValidTraitName: aSymbol) ifFalse: [self error:'Invalid trait name']. (self environment == aSystemDictionary and: [self name = aSymbol and: [self category = categorySymbol]]) ifTrue: [^self]. ((aSystemDictionary includesKey: aSymbol) and: [(aSystemDictionary at: aSymbol) ~~ self]) ifTrue: [self error: 'The name ''' , aSymbol , ''' is already used']. (self environment notNil and: [self name notNil and: [self name ~= aSymbol]]) ifTrue: [ self environment renameClass: self as: aSymbol]. self name: aSymbol. self environment: aSystemDictionary. [self environment at: self name put: self] on: AttemptToWriteReadOnlyGlobal do: [:n | n resume: true]. self environment organization classify: self name under: categorySymbol. ^ true! ----- Method: Trait>>theMetaClass (in category 'accessing') ----- theMetaClass ^self classTrait! ----- Method: Trait>>unload (in category 'initialize') ----- unload "For polymorphism with classes. Do nothing"! ----- Method: TraitDescription class>>conflict (in category 'conflict methods') ----- conflict "This method has a trait conflict" ^self traitConflict! ----- Method: TraitDescription class>>conflict: (in category 'conflict methods') ----- conflict: arg1 "This method has a trait conflict" ^self traitConflict! ----- Method: TraitDescription class>>conflict:with: (in category 'conflict methods') ----- conflict: arg1 with: arg2 "This method has a trait conflict" ^self traitConflict! ----- Method: TraitDescription class>>conflict:with:with: (in category 'conflict methods') ----- conflict: arg1 with: arg2 with: arg3 "This method has a trait conflict" ^self traitConflict! ----- Method: TraitDescription class>>conflict:with:with:with: (in category 'conflict methods') ----- conflict: arg1 with: arg2 with: arg3 with: arg4 "This method has a trait conflict" ^self traitConflict! ----- Method: TraitDescription class>>conflict:with:with:with:with: (in category 'conflict methods') ----- conflict: arg1 with: arg2 with: arg3 with: arg4 with: arg5 "This method has a trait conflict" ^self traitConflict! ----- Method: TraitDescription class>>conflict:with:with:with:with:with: (in category 'conflict methods') ----- conflict: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 "This method has a trait conflict" ^self traitConflict! ----- Method: TraitDescription class>>conflict:with:with:with:with:with:with: (in category 'conflict methods') ----- conflict: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 with: arg7 "This method has a trait conflict" ^self traitConflict! ----- Method: TraitDescription class>>conflict:with:with:with:with:with:with:with: (in category 'conflict methods') ----- conflict: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 with: arg7 with: arg8 "This method has a trait conflict" ^self traitConflict! ----- Method: TraitDescription>>+ (in category 'operations') ----- + aTrait "Creates a composition with the receiver and aTrait" aTrait traitsDo:[:t| self == t ifTrue:[TraitCompositionException signal: 'Trait ' , self asString, ' already in composition']]. ^TraitComposition withAll: {self}, aTrait asTraitComposition! ----- Method: TraitDescription>>- (in category 'operations') ----- - anArrayOfSelectors "Creates an exclusion" ^TraitExclusion with: self exclusions: anArrayOfSelectors! ----- Method: TraitDescription>>@ (in category 'operations') ----- @ anArrayOfAssociations "Creates an alias" ^TraitAlias with: self aliases: anArrayOfAssociations! ----- Method: TraitDescription>>addSelectorSilently:withMethod: (in category 'operations') ----- addSelectorSilently: selector withMethod: compiledMethod "Overridden to update the users of this trait" super addSelectorSilently: selector withMethod: compiledMethod. self users do:[:each| each updateTraits].! ----- Method: TraitDescription>>addTraitUser: (in category 'accessing') ----- addTraitUser: aTrait users := self users copyWith: aTrait. ! ----- Method: TraitDescription>>allClassVarNames (in category 'accessing') ----- allClassVarNames "Traits have no class var names" ^#()! ----- Method: TraitDescription>>asTraitComposition (in category 'converting') ----- asTraitComposition ^TraitComposition with: self! ----- Method: TraitDescription>>classPool (in category 'accessing') ----- classPool "Traits have no class pool" ^ Dictionary new! ----- Method: TraitDescription>>copy (in category 'copying') ----- copy self error: 'Traits cannot be trivially copied'! ----- Method: TraitDescription>>copyTraitExpression (in category 'copying') ----- copyTraitExpression "Copy all except the actual traits" ^self! ----- Method: TraitDescription>>fileOut (in category 'fileIn/Out') ----- fileOut "Create a file whose name is the name of the receiver with '.st' as the extension, and file a description of the receiver onto it." ^ self fileOutAsHtml: false! ----- Method: TraitDescription>>fileOutAsHtml: (in category 'fileIn/Out') ----- fileOutAsHtml: useHtml "File a description of the receiver onto a new file whose base name is the name of the receiver." | internalStream | internalStream := WriteStream on: (String new: 100). internalStream header; timeStamp. self fileOutOn: internalStream moveSource: false toFile: 0. internalStream trailer. FileStream writeSourceCodeFrom: internalStream baseName: self name isSt: true useHtml: useHtml. ! ----- Method: TraitDescription>>includesTrait: (in category 'testing') ----- includesTrait: aTrait ^self == aTrait or:[super includesTrait: aTrait]! ----- Method: TraitDescription>>installTraitsFrom: (in category 'operations') ----- installTraitsFrom: aTraitComposition super installTraitsFrom: aTraitComposition. self users do:[:each| each updateTraits].! ----- Method: TraitDescription>>isBaseTrait (in category 'testing') ----- isBaseTrait ^false! ----- Method: TraitDescription>>isClassTrait (in category 'testing') ----- isClassTrait ^false! ----- Method: TraitDescription>>isTrait (in category 'testing') ----- isTrait ^true! ----- Method: TraitDescription>>isTraitTransformation (in category 'testing') ----- isTraitTransformation "Polymorphic with TraitTransformation" ^false! ----- Method: TraitDescription>>notifyOfRecategorizedSelector:from:to: (in category 'operations') ----- notifyOfRecategorizedSelector: element from: oldCategory to: newCategory super notifyOfRecategorizedSelector: element from: oldCategory to: newCategory. self users do:[:each| each classify: element under: newCategory from: oldCategory trait: self].! ----- Method: TraitDescription>>printHierarchy (in category 'printing') ----- printHierarchy "For hierarchy view in the browser; print the users of a trait" ^String streamContents:[:s| self printUsersOf: self on: s level: 0].! ----- Method: TraitDescription>>printUsersOf:on:level: (in category 'printing') ----- printUsersOf: aClass on: aStream level: indent aStream crtab: indent. aStream nextPutAll: aClass name. aClass isTrait ifTrue:[ aClass users do:[:each| self printUsersOf: aClass on: aStream level: indent+1]. ]. ! ----- Method: TraitDescription>>removeTraitUser: (in category 'accessing') ----- removeTraitUser: aTrait users := self users copyWithout: aTrait. ! ----- Method: TraitDescription>>sharedPools (in category 'accessing') ----- sharedPools "Traits have no shared pools" ^ Dictionary new! ----- Method: TraitDescription>>trait (in category 'accessing') ----- trait ^self! ----- Method: TraitDescription>>traitsDo: (in category 'operations') ----- traitsDo: aBlock aBlock value: self.! ----- Method: TraitDescription>>users (in category 'accessing') ----- users ^users ifNil:[#()]! ----- Method: TraitDescription>>users: (in category 'accessing') ----- users: aCollection users := aCollection! ----- Method: ClassOrganizer>>isTraitOrganizer (in category '*Traits-Kernel') ----- isTraitOrganizer "Answer true if this is a TraitOrganizer" ^false! ----- Method: ClassOrganizer>>traitComposition (in category '*Traits-Kernel') ----- traitComposition "Answer the receiver's trait composition" ^#()! ClassOrganizer subclass: #TraitOrganizer instanceVariableNames: 'traitComposition' classVariableNames: '' poolDictionaries: '' category: 'Traits-Kernel'! !TraitOrganizer commentStamp: 'ar 1/9/2010 17:56' prior: 0! A class organizer containing state for traits.! ----- Method: TraitOrganizer>>isTraitOrganizer (in category 'testing') ----- isTraitOrganizer "Answer true if this is a TraitOrganizer" ^true! ----- Method: TraitOrganizer>>traitComposition (in category 'accessing') ----- traitComposition "Answer the receiver's trait composition" ^traitComposition ifNil:[traitComposition := TraitComposition new]! ----- Method: TraitOrganizer>>traitComposition: (in category 'accessing') ----- traitComposition: aTraitComposition "Install the receiver's trait composition" traitComposition := aTraitComposition.! ----- Method: SequenceableCollection>>asTraitComposition (in category '*Traits') ----- asTraitComposition "For convenience the composition {T1. T2 ...} is the same as T1 + T2 + ..." ^self isEmpty ifFalse: [ self size = 1 ifTrue: [self first asTraitComposition] ifFalse: [ self copyWithoutFirst inject: self first into: [:left :right | left + right]]] ifTrue: [ClassDescription newTraitComposition]! Error subclass: #TraitCompositionException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Traits-Composition'! !TraitCompositionException commentStamp: 'ar 12/29/2009 18:13' prior: 0! Signals invalid trait compositions.! ----- Method: Object>>explicitRequirement (in category '*Traits') ----- explicitRequirement self error: 'Explicitly required method'! ----- Method: Object>>requirement (in category '*Traits') ----- requirement | sender | sender := thisContext sender. ^ NotImplemented signal: ('{1} or a superclass should implement {2} from trait {3}' format: {self className. sender selector. sender method originalTraitMethod methodClass})! Object subclass: #TraitTransformation instanceVariableNames: 'subject users' classVariableNames: '' poolDictionaries: '' category: 'Traits-Composition'! !TraitTransformation commentStamp: 'ar 12/29/2009 18:14' prior: 0! A trait transformation is an instance of one of my concrete subclasses, TraitAlias or TraitExclusion. These represent a transformation of a trait, specified by the alias and exclusion operators. I define an instance variable named subject which holds the object that is transformed. Thus, an alias transformation has as its subject a trait, and a trait exclusion has as its subject either a trait alias or a trait. Each of the concrete transformation classes implement the method allSelectors according to the transformation it represents. ! TraitTransformation subclass: #TraitAlias instanceVariableNames: 'aliases' classVariableNames: '' poolDictionaries: '' category: 'Traits-Composition'! !TraitAlias commentStamp: 'ar 12/29/2009 18:14' prior: 0! A trait transformation representing the alias (->) operator.! ----- Method: TraitAlias class>>assertValidAliasDefinition: (in category 'instance creation') ----- assertValidAliasDefinition: anArrayOfAssociations "Throw an exceptions if the alias definition is not valid. It is expected to be a collection of associations and the number of arguments of the alias selector has to be the same as the original selector." ((anArrayOfAssociations isKindOf: Collection) and: [ anArrayOfAssociations allSatisfy: [:each | each isKindOf: Association]]) ifFalse: [ self error: 'Invalid alias definition: Not a collection of associations.']. (anArrayOfAssociations allSatisfy: [:association | (association key numArgs = association value numArgs and: [ (association key numArgs = -1) not])]) ifFalse: [ TraitCompositionException signal: 'Invalid alias definition: Alias and original selector have to have the same number of arguments.']! ----- Method: TraitAlias class>>with:aliases: (in category 'instance creation') ----- with: aTraitComposition aliases: anArrayOfAssociations self assertValidAliasDefinition: anArrayOfAssociations. ^self new subject: aTraitComposition; initializeFrom: anArrayOfAssociations; yourself! ----- Method: TraitAlias>>- (in category 'converting') ----- - anArrayOfSelectors ^TraitExclusion with: self exclusions: anArrayOfSelectors! ----- Method: TraitAlias>>@ (in category 'converting') ----- @ anArrayOfAssociations ^TraitAlias with: subject aliases: (anArrayOfAssociations, self aliases)! ----- Method: TraitAlias>>aliases (in category 'accessing') ----- aliases "Collection of associations where key is the alias and value the original selector." ^aliases! ----- Method: TraitAlias>>aliases: (in category 'accessing') ----- aliases: aCollection "Collection of associations where key is the alias and value the original selector." aliases := aCollection! ----- Method: TraitAlias>>copyTraitExpression (in category 'operations') ----- copyTraitExpression "Copy all except the actual traits" ^TraitAlias with: subject aliases: aliases! ----- Method: TraitAlias>>includesSelector: (in category 'operations') ----- includesSelector: selector "Answers true if the receiver provides the selector" ^(subject includesSelector: selector) or:[aliases anySatisfy:[:assoc| assoc key == selector]]! ----- Method: TraitAlias>>initialize (in category 'initialize-release') ----- initialize super initialize. aliases := #().! ----- Method: TraitAlias>>initializeFrom: (in category 'initialize-release') ----- initializeFrom: anArrayOfAssociations | newNames | newNames := (anArrayOfAssociations collect: [:each | each key]) asIdentitySet. newNames size < anArrayOfAssociations size ifTrue: [ TraitCompositionException signal: 'Cannot use the same alias name twice']. anArrayOfAssociations do: [:each | (newNames includes: each value) ifTrue: [ TraitCompositionException signal: 'Cannot define an alias for an alias']]. aliases := anArrayOfAssociations. ! ----- Method: TraitAlias>>isAliasSelector: (in category 'testing') ----- isAliasSelector: selector ^(self isLocalAliasSelector: selector) or:[super isAliasSelector: selector]! ----- Method: TraitAlias>>isLocalAliasSelector: (in category 'testing') ----- isLocalAliasSelector: selector ^(aliases anySatisfy:[:assoc| assoc key == selector])! ----- Method: TraitAlias>>printOn: (in category 'operations') ----- printOn: s "Answer the trait composition string (used for class definitions)" s nextPutAll: subject asString. s nextPutAll: ' @ {'. aliases do:[:assoc| s print: assoc] separatedBy:[s nextPutAll:'. ']. s nextPutAll: '}'. ! ----- Method: TraitAlias>>selectorsAndMethodsDo: (in category 'operations') ----- selectorsAndMethodsDo: aBlock "enumerates all selectors and methods in a trait composition" subject selectorsAndMethodsDo: aBlock. aliases do:[:assoc| | method | "Method can be nil during removals" method := subject compiledMethodAt: assoc value ifAbsent:[nil]. method ifNotNil:[aBlock value: assoc key value: method]. ].! TraitTransformation subclass: #TraitExclusion instanceVariableNames: 'exclusions' classVariableNames: '' poolDictionaries: '' category: 'Traits-Composition'! !TraitExclusion commentStamp: 'ar 12/29/2009 18:13' prior: 0! A trait transformation representing the exclusion (-) operator.! ----- Method: TraitExclusion class>>with:exclusions: (in category 'instance creation') ----- with: aTraitComposition exclusions: anArrayOfSelectors ^self new subject: aTraitComposition; exclusions: anArrayOfSelectors; yourself ! ----- Method: TraitExclusion>>- (in category 'converting') ----- - anArrayOfSelectors ^TraitExclusion with: subject exclusions: (anArrayOfSelectors, exclusions asArray)! ----- Method: TraitExclusion>>@ (in category 'converting') ----- @ anArrayOfAssociations TraitCompositionException signal: 'Invalid trait exclusion. Aliases have to be specified before exclusions.' ! ----- Method: TraitExclusion>>copyTraitExpression (in category 'composition') ----- copyTraitExpression "Copy all except the actual traits" ^TraitExclusion with: subject exclusions: exclusions asArray! ----- Method: TraitExclusion>>exclusions (in category 'accessing') ----- exclusions ^exclusions! ----- Method: TraitExclusion>>exclusions: (in category 'accessing') ----- exclusions: aCollection exclusions := Set withAll: aCollection! ----- Method: TraitExclusion>>includesSelector: (in category 'composition') ----- includesSelector: selector "Answers true if the receiver provides the selector" ^(subject includesSelector: selector) and:[(exclusions includes: selector) not]! ----- Method: TraitExclusion>>initialize (in category 'initialize') ----- initialize super initialize. exclusions := Set new. ! ----- Method: TraitExclusion>>printOn: (in category 'composition') ----- printOn: aStream "Answer the trait composition string (used for class definitions)" aStream nextPutAll: subject asString. aStream nextPutAll: ' - {'. exclusions asArray sort do:[:exc| aStream store: exc] separatedBy:[aStream nextPutAll: '. ']. aStream nextPutAll: '}'.! ----- Method: TraitExclusion>>selectorsAndMethodsDo: (in category 'composition') ----- selectorsAndMethodsDo: aBlock "enumerates all selectors and methods in a trait composition" ^subject selectorsAndMethodsDo:[:sel :meth| (exclusions includes: sel) ifFalse:[aBlock value: sel value: meth]. ].! ----- Method: TraitTransformation>>+ (in category 'converting') ----- + aTrait "Just like ordered collection" ^TraitComposition withAll: {self. aTrait}! ----- Method: TraitTransformation>>- (in category 'converting') ----- - anArrayOfSelectors ^self subclassResponsibility! ----- Method: TraitTransformation>>@ (in category 'converting') ----- @ anArrayOfAssociations ^self subclassResponsibility! ----- Method: TraitTransformation>>addTraitUser: (in category 'accessing') ----- addTraitUser: aTrait users := users copyWith: aTrait. subject addTraitUser: aTrait. ! ----- Method: TraitTransformation>>allTraits (in category 'accessing') ----- allTraits ^subject allTraits! ----- Method: TraitTransformation>>asTraitComposition (in category 'converting') ----- asTraitComposition ^TraitComposition with: self! ----- Method: TraitTransformation>>asTraitTransform (in category 'converting') ----- asTraitTransform ^self! ----- Method: TraitTransformation>>copyTraitExpression (in category 'operations') ----- copyTraitExpression "Copy all except the actual traits" ^self subclassResponsibility! ----- Method: TraitTransformation>>includesTrait: (in category 'testing') ----- includesTrait: aTrait ^subject includesTrait: aTrait! ----- Method: TraitTransformation>>initialize (in category 'initialize') ----- initialize super initialize. users := #().! ----- Method: TraitTransformation>>isAliasSelector: (in category 'testing') ----- isAliasSelector: selector ^subject isAliasSelector: selector! ----- Method: TraitTransformation>>isLocalAliasSelector: (in category 'testing') ----- isLocalAliasSelector: selector ^false! ----- Method: TraitTransformation>>isTraitTransformation (in category 'testing') ----- isTraitTransformation "Polymorphic with Trait" ^true! ----- Method: TraitTransformation>>removeTraitUser: (in category 'accessing') ----- removeTraitUser: aTrait users := users copyWithout: aTrait. subject removeTraitUser: aTrait.! ----- Method: TraitTransformation>>selectorsAndMethodsDo: (in category 'operations') ----- selectorsAndMethodsDo: aBlock "enumerates all selectors and methods in a trait composition" ^self subclassResponsibility! ----- Method: TraitTransformation>>subject: (in category 'accessing') ----- subject: aSubject subject := aSubject.! ----- Method: TraitTransformation>>trait (in category 'accessing') ----- trait ^subject trait! ----- Method: TraitTransformation>>traitsDo: (in category 'accessing') ----- traitsDo: aBlock ^subject traitsDo: aBlock! ----- Method: TraitTransformation>>updateSelector:withTraitMethod:from: (in category 'operations') ----- updateSelector: aSelector withTraitMethod: compiledMethod from: aTrait "broadcasts the change of a selector to all users of a trait" ^self subclassResponsibility! ----- Method: TraitTransformation>>updateTraits (in category 'operations') ----- updateTraits "Recompute my users traits composition" users do:[:each| each updateTraits].! OrderedCollection subclass: #TraitComposition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Traits-Composition'! !TraitComposition commentStamp: 'ar 12/29/2009 18:13' prior: 0! A trait composition is a collection of Traits or TraitTransformations.! ----- Method: TraitComposition>>+ (in category 'converting') ----- + aTrait self traitsDo:[:t| (t == aTrait trait) ifTrue:[^TraitCompositionException signal: 'Trait ' , aTrait trait asString, ' already in composition']]. self addLast: aTrait. ^self! ----- Method: TraitComposition>>- (in category 'converting') ----- - anArray "the modifier operators #@ and #- bind stronger than +. Thus, #@ or #- sent to a sum will only affect the most right summand" self addLast: (self removeLast - anArray)! ----- Method: TraitComposition>>@ (in category 'converting') ----- @ anArrayOfAssociations "the modifier operators #@ and #- bind stronger than +. Thus, #@ or #- sent to a sum will only affect the most right summand" self addLast: (self removeLast @ anArrayOfAssociations)! ----- Method: TraitComposition>>allTraits (in category 'accessing') ----- allTraits ^self gather:[:each| each allTraits copyWith: each trait]! ----- Method: TraitComposition>>asTraitComposition (in category 'converting') ----- asTraitComposition ^self! ----- Method: TraitComposition>>copyTraitExpression (in category 'operations') ----- copyTraitExpression "Copy all except the actual traits" ^self collect:[:each| each copyTraitExpression].! ----- Method: TraitComposition>>isAliasSelector: (in category 'operations') ----- isAliasSelector: selector "enumerates all selectors and methods in a trait composition" ^self anySatisfy:[:any| any isAliasSelector: selector]! ----- Method: TraitComposition>>isLocalAliasSelector: (in category 'operations') ----- isLocalAliasSelector: selector "Return true if the selector aSymbol is an alias defined in the receiver." ^self anySatisfy:[:any| any isTraitTransformation and:[any isLocalAliasSelector: selector]]! ----- Method: TraitComposition>>isTraitTransformation (in category 'testing') ----- isTraitTransformation "Polymorphic with TraitTransformation" ^false! ----- Method: TraitComposition>>printOn: (in category 'converting') ----- printOn: aStream "Answer the trait composition string (used for class definitions)" aStream nextPutAll: self traitCompositionString. ! ----- Method: TraitComposition>>selectorsAndMethodsDo: (in category 'operations') ----- selectorsAndMethodsDo: aBlock "enumerates all selectors and methods in a trait composition" self do:[:each| each selectorsAndMethodsDo: aBlock].! ----- Method: TraitComposition>>traitCompositionString (in category 'operations') ----- traitCompositionString "Answer the trait composition string (used for class definitions)" self size = 0 ifTrue:[^'{}']. self size = 1 ifTrue:[^self first asString]. ^String streamContents:[:s| self do:[:each| s nextPutAll: each asString] separatedBy:[s nextPutAll: ' + ']. ].! ----- Method: TraitComposition>>traits (in category 'accessing') ----- traits ^Array streamContents:[:s| self traitsDo:[:t| s nextPut: t]]! ----- Method: TraitComposition>>traitsDo: (in category 'accessing') ----- traitsDo: aBlock ^self do:[:each| each traitsDo: aBlock]!

1 0

Squeak 4.6: FlexibleVocabularies-bf.13.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of FlexibleVocabularies to project Squeak 4.6: http://source.squeak.org/squeak46/FlexibleVocabularies-bf.13.mcz ==================== Summary ==================== Name: FlexibleVocabularies-bf.13 Author: bf Time: 11 September 2013, 5:36:17.823 pm UUID: 55c72a72-619e-4a81-831f-303600bbd792 Ancestors: FlexibleVocabularies-ar.12 Remove empty category. ==================== Snapshot ====================

1 0

Squeak 4.6: MorphicTests-mt.31.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of MorphicTests to project Squeak 4.6: http://source.squeak.org/squeak46/MorphicTests-mt.31.mcz ==================== Summary ==================== Name: MorphicTests-mt.31 Author: mt Time: 19 May 2015, 4:17:55.16 pm UUID: 60717262-4e28-a549-a8a2-6918f0a28581 Ancestors: MorphicTests-mt.30 Tests added for scroll panes. ==================== Snapshot ==================== SystemOrganization addCategory: #'MorphicTests-Basic'! SystemOrganization addCategory: #'MorphicTests-Kernel'! SystemOrganization addCategory: #'MorphicTests-Layouts'! SystemOrganization addCategory: #'MorphicTests-Support'! SystemOrganization addCategory: #'MorphicTests-Text Support'! SystemOrganization addCategory: #'MorphicTests-ToolBuilder'! SystemOrganization addCategory: #'MorphicTests-Widgets'! SystemOrganization addCategory: #'MorphicTests-Worlds'! ValueHolder subclass: #MorphicTestTextModel instanceVariableNames: 'flags result' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Text Support'! ----- Method: MorphicTestTextModel>>debugExpression: (in category 'do-its general') ----- debugExpression: anExpression self flags add: #expressionDebugged. self result: (Compiler evaluate: anExpression).! ----- Method: MorphicTestTextModel>>doItContext (in category 'do-its support') ----- doItContext self flags add: #doItContext. ^ nil! ----- Method: MorphicTestTextModel>>doItReceiver (in category 'do-its support') ----- doItReceiver self flags add: #doItReceiver. ^ self result! ----- Method: MorphicTestTextModel>>exploreIt:result: (in category 'do-its') ----- exploreIt: expression result: object self flags add: #explored. self result: object.! ----- Method: MorphicTestTextModel>>expressionEvaluated:result: (in category 'do-its general') ----- expressionEvaluated: anExpression result: anObject self flags add: #expressionEvaluated. self result: anObject.! ----- Method: MorphicTestTextModel>>flags (in category 'as yet unclassified') ----- flags ^ flags ifNil: [flags := Bag new]! ----- Method: MorphicTestTextModel>>hasFlag: (in category 'as yet unclassified') ----- hasFlag: aSymbol ^ self flags includes: aSymbol! ----- Method: MorphicTestTextModel>>inspectIt:result: (in category 'do-its') ----- inspectIt: expression result: object self flags add: #inspected. self result: object.! ----- Method: MorphicTestTextModel>>printIt:result: (in category 'do-its') ----- printIt: expression result: object self flags add: #printed. self result: object printString.! ----- Method: MorphicTestTextModel>>result (in category 'as yet unclassified') ----- result ^ result! ----- Method: MorphicTestTextModel>>result: (in category 'as yet unclassified') ----- result: anObject result := anObject.! MorphicTestTextModel subclass: #MorphicTestTextModelWithEvaluationSupport instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Text Support'! ----- Method: MorphicTestTextModelWithEvaluationSupport>>evaluateExpression: (in category 'do-its general') ----- evaluateExpression: anExpression self flags add: #expressionEvaluated. self result: (Compiler evaluate: anExpression asString). ^ self result! HashAndEqualsTestCase subclass: #TextAnchorTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Text Support'! ----- Method: TextAnchorTest>>setUp (in category 'initialize-release') ----- setUp super setUp. prototypes add: (TextAnchor new anchoredMorph: RectangleMorph new initialize); add: (TextAnchor new anchoredMorph: EllipseMorph new initialize) ! ----- Method: TextAnchorTest>>testBeginWithAnAnchor (in category 'initialize-release') ----- testBeginWithAnAnchor | text morph model | text := Text streamContents: [ : stream | stream nextPutAll: (Text string: (String value: 1) attributes: {TextAnchor new anchoredMorph: Morph new. TextColor color: Color transparent}) ; nextPutAll: ' should be able to begin with an embedded object. ' ]. model := text -> nil. morph := PluggableTextMorph on: model text: #key accept: nil. [ morph openInWorld ] ensure: [ morph delete ]! HashAndEqualsTestCase subclass: #TextLineTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Text Support'! ----- Method: TextLineTest>>setUp (in category 'initialize-release') ----- setUp super setUp. prototypes add: (TextLine start: 1 stop: 50 internalSpaces: 2 paddingWidth: 1) ! ToolBuilderTests subclass: #MorphicToolBuilderTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-ToolBuilder'! !MorphicToolBuilderTests commentStamp: 'ar 2/11/2005 15:02' prior: 0! Tests for the Morphic tool builder.! ----- Method: MorphicToolBuilderTests>>acceptWidgetText (in category 'support') ----- acceptWidgetText widget hasUnacceptedEdits: true. widget accept.! ----- Method: MorphicToolBuilderTests>>buttonWidgetEnabled (in category 'support') ----- buttonWidgetEnabled "Answer whether the current widget (a button) is currently enabled" ^widget enabled! ----- Method: MorphicToolBuilderTests>>changeListWidget (in category 'support') ----- changeListWidget widget changeModelSelection: widget getCurrentSelectionIndex + 1.! ----- Method: MorphicToolBuilderTests>>expectedButtonSideEffects (in category 'support') ----- expectedButtonSideEffects ^#(getColor getState getEnabled)! ----- Method: MorphicToolBuilderTests>>fireButtonWidget (in category 'support') ----- fireButtonWidget widget performAction.! ----- Method: MorphicToolBuilderTests>>fireMenuItemWidget (in category 'support') ----- fireMenuItemWidget (widget itemWithWording: 'Menu Item') ifNotNil: [:item | item doButtonAction]! ----- Method: MorphicToolBuilderTests>>setUp (in category 'support') ----- setUp super setUp. builder := MorphicToolBuilder new.! ----- Method: MorphicToolBuilderTests>>testWindowDynamicLabel (in category 'tests-window') ----- testWindowDynamicLabel self makeWindow. self assert: (widget label = 'TestLabel').! ----- Method: MorphicToolBuilderTests>>testWindowStaticLabel (in category 'tests-window') ----- testWindowStaticLabel | spec | spec := builder pluggableWindowSpec new. spec model: self. spec children: #(). spec label: 'TestLabel'. widget := builder build: spec. self assert: (widget label = 'TestLabel').! ----- Method: MorphicToolBuilderTests>>widgetColor (in category 'support') ----- widgetColor "Answer color from widget" ^widget color! Morph subclass: #TestInWorldMorph instanceVariableNames: 'intoWorldCount outOfWorldCount' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Kernel'! !TestInWorldMorph commentStamp: 'sd 6/5/2005 10:25' prior: 0! Helper class for MorphTest! ----- Method: TestInWorldMorph>>initialize (in category 'as yet unclassified') ----- initialize super initialize. outOfWorldCount := intoWorldCount := 0.! ----- Method: TestInWorldMorph>>intoWorld: (in category 'as yet unclassified') ----- intoWorld: aWorld aWorld ifNil:[^self]. super intoWorld: aWorld. intoWorldCount := intoWorldCount + 1. ! ----- Method: TestInWorldMorph>>intoWorldCount (in category 'as yet unclassified') ----- intoWorldCount ^intoWorldCount! ----- Method: TestInWorldMorph>>outOfWorld: (in category 'as yet unclassified') ----- outOfWorld: aWorld aWorld ifNil:[^self]. super outOfWorld: aWorld. outOfWorldCount := outOfWorldCount + 1. ! ----- Method: TestInWorldMorph>>outOfWorldCount (in category 'as yet unclassified') ----- outOfWorldCount ^outOfWorldCount! TestCase subclass: #BalloonFontTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Widgets'! ----- Method: BalloonFontTest>>testDefaultFont (in category 'tests') ----- testDefaultFont "(self selector: #testDefaultFont) debug" self assert: RectangleMorph new balloonFont = BalloonMorph balloonFont. self assert: RectangleMorph new defaultBalloonFont = BalloonMorph balloonFont.! ----- Method: BalloonFontTest>>testSpecificFont (in category 'tests') ----- testSpecificFont "(self selector: #testSpecificFont) debug" | aMorph | aMorph := RectangleMorph new. self assert: RectangleMorph new balloonFont = BalloonMorph balloonFont. self assert: RectangleMorph new defaultBalloonFont = BalloonMorph balloonFont. aMorph balloonFont: (StrikeFont familyName: #ComicPlain size: 19). self assert: aMorph balloonFont = (StrikeFont familyName: #ComicPlain size: 19). "The next test is horrible because I do no know how to access the font with the appropiate interface" self assert: (((BalloonMorph getTextMorph: 'lulu' for: aMorph) text runs at: 1) at: 1) font = (StrikeFont familyName: #ComicPlain size: 19)! TestCase subclass: #CircleMorphBugs instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Basic'! ----- Method: CircleMorphBugs>>testCircleInstance (in category 'as yet unclassified') ----- testCircleInstance "" "self run: #testCircleInstance" | circ | self assert: (circ := CircleMorph initializedInstance) extent = circ extent x asPoint ! TestCase subclass: #FormCanvasTest instanceVariableNames: 'morph' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Support'! ----- Method: FormCanvasTest>>testDefaultClipRect (in category 'tests') ----- testDefaultClipRect self assert: (FormCanvas extent: 222@111) clipRect = (0@0 corner: 222@111). self assert: (FormCanvas extent: 2222@11) clipRect = (0@0 corner: 2222@11). self assert: (FormCanvas extent: 22222@1) clipRect = (0@0 corner: 22222@1). ! ----- Method: FormCanvasTest>>testFrameAndFillDegenerateRoundRect01 (in category 'tests') ----- testFrameAndFillDegenerateRoundRect01 | fill canvas smallRect | fill := GradientFillStyle sample. canvas := FormCanvas extent: 100@100. canvas fillColor: Color black. smallRect := 0@0 corner: 20@20. "This should not throw an exception." canvas frameAndFillRoundRect: smallRect radius: smallRect width / 2 + 1 fillStyle: fill borderWidth: 0 borderColor: Color lightGray.! ----- Method: FormCanvasTest>>testFrameAndFillDegenerateRoundRect02 (in category 'tests') ----- testFrameAndFillDegenerateRoundRect02 | fill canvas smallRect | fill := GradientFillStyle sample. canvas := FormCanvas extent: 100@100. canvas fillColor: Color black. smallRect := 0@0 corner: 20@20. "This should not throw an exception." canvas frameAndFillRoundRect: smallRect radius: 0 fillStyle: fill borderWidth: 0 borderColor: Color lightGray.! TestCase subclass: #LayoutFrameTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Layouts'! ----- Method: LayoutFrameTest>>testInset (in category 'as yet unclassified') ----- testInset | lf rectangle | lf := LayoutFrame new leftFraction: 0 offset: 10; topFraction: 0 offset: 10; rightFraction: 1 offset: -10; bottomFraction: 1 offset: -10; yourself. rectangle := lf layout: nil in: (50@10 corner: 150@70). self assert: (60@20 corner: 140@60) = rectangle! ----- Method: LayoutFrameTest>>testLeftTopAligned (in category 'as yet unclassified') ----- testLeftTopAligned | lf rectangle | lf := LayoutFrame new leftFraction: 0 offset: 10; topFraction: 0 offset: 10; rightFraction: 0 offset: 60; bottomFraction: 0 offset: 25; yourself. rectangle := lf layout: nil in: (50@10 corner: 150@70). self assert: (60@20 corner: 110@35) = rectangle! ----- Method: LayoutFrameTest>>testRightBottomQuadrant (in category 'as yet unclassified') ----- testRightBottomQuadrant | lf rectangle | lf := LayoutFrame new leftFraction: 1/2 offset: 1; topFraction: 1/2 offset: 1; rightFraction: 1 offset: -2; bottomFraction: 1 offset: -2; yourself. rectangle := lf layout: nil in: (50@10 corner: 150@70). self assert: (101@41 corner: 148@68) = rectangle! ----- Method: LayoutFrameTest>>testSpaceFill (in category 'as yet unclassified') ----- testSpaceFill | lf rectangle | lf := LayoutFrame new leftFraction: 0 offset: 0; topFraction: 0 offset: 0; rightFraction: 1 offset: 0; bottomFraction: 1 offset: 0; yourself. rectangle := lf layout: nil in: (50@10 corner: 150@70). self assert: (50@10 corner: 150@70) = rectangle! TestCase subclass: #MCPTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Kernel'! ----- Method: MCPTest>>defaultBounds (in category 'constants') ----- defaultBounds "the default bounds for morphs" ^ 0 @ 0 corner: 50 @ 40 ! ----- Method: MCPTest>>defaultTop (in category 'constants') ----- defaultTop "the default top for morphs" ^ self defaultBounds top ! ----- Method: MCPTest>>testIsMorphicModel (in category 'tests') ----- testIsMorphicModel "test isMorphicModel" self deny: Object new isMorphicModel. self deny: Morph new isMorphicModel. self assert: MorphicModel new isMorphicModel. ! ----- Method: MCPTest>>testIsSystemWindow (in category 'tests') ----- testIsSystemWindow "test isSystemWindow" self deny: Object new isSystemWindow. self assert: SystemWindow new isSystemWindow.! ----- Method: MCPTest>>testTop (in category 'tests') ----- testTop "test the #top: messages and its consequences" | morph factor newTop newBounds | morph := Morph new. "" factor := 10. newTop := self defaultTop + factor. newBounds := self defaultBounds translateBy: 0 @ factor. "" morph top: newTop. "" self assert: morph top = newTop; assert: morph bounds = newBounds! TestCase subclass: #MorphTest instanceVariableNames: 'morph world' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Kernel'! !MorphTest commentStamp: '<historical>' prior: 0! This is the unit test for the class Morph. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! MorphTest subclass: #CircleMorphTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Basic'! !CircleMorphTest commentStamp: 'tlk 5/21/2006 14:16' prior: 0! A CircleMorphTest is a subclass of MorphTest. It was first implemented when removing some unused and broken functionality. My fixtures are morph, a CircleMorph and world. ! ----- Method: CircleMorphTest>>setUp (in category 'initialize-release') ----- setUp morph := CircleMorph new! MorphTest subclass: #MorphBugs instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Basic'! ----- Method: MorphBugs>>testAdhereToEdgeEternity (in category 'tests') ----- testAdhereToEdgeEternity | r | r := RectangleMorph new openInWorld: self getWorld. self shouldnt: [ r adhereToEdge: #eternity ] raise: Exception.! ----- Method: MorphTest>>createAndAddMorphs: (in category 'support') ----- createAndAddMorphs: someNames (self createMorphs: #(a b)) do: [:newMorph | morph addMorphBack: newMorph].! ----- Method: MorphTest>>createMorphs: (in category 'support') ----- createMorphs: someNames ^ someNames collect: [:nm | Morph new name: nm]! ----- Method: MorphTest>>getSubmorph: (in category 'support') ----- getSubmorph: name ^ morph submorphs detect: [:m | m knownName = name]! ----- Method: MorphTest>>getSubmorphNames (in category 'support') ----- getSubmorphNames ^ morph submorphs collect: [:m | m knownName asSymbol]! ----- Method: MorphTest>>getSubmorphs: (in category 'support') ----- getSubmorphs: someNames ^ someNames collect: [:nm | self getSubmorph: nm]! ----- Method: MorphTest>>getWorld (in category 'initialize-release') ----- getWorld ^ world ifNil: [ world := PasteUpMorph newWorldForProject: nil. world viewBox: (0@0 extent: world extent); yourself]! ----- Method: MorphTest>>setUp (in category 'initialize-release') ----- setUp morph := Morph new! ----- Method: MorphTest>>tearDown (in category 'initialize-release') ----- tearDown morph delete.! ----- Method: MorphTest>>testAddAllMorphs (in category 'testing - add/remove submorphs') ----- testAddAllMorphs self createAndAddMorphs: #(a b). self assert: #(a b) equals: self getSubmorphNames. morph addAllMorphs: (self createMorphs: #(x y)). self assert: #(a b x y) equals: self getSubmorphNames. morph removeAllMorphs. morph addAllMorphs: (self createMorphs: #(x y)). self assert: #(x y) equals: self getSubmorphNames.! ----- Method: MorphTest>>testAddAllMorphsAfter (in category 'testing - add/remove submorphs') ----- testAddAllMorphsAfter self createAndAddMorphs: #(a b). self assert: #(a b) equals: self getSubmorphNames. morph addAllMorphs: (self createMorphs: #(x y)) after: (self getSubmorph: #a). self assert: #(a x y b) equals: self getSubmorphNames. morph addAllMorphs: (self getSubmorphs: #(x y)) after: (self getSubmorph: #b). self assert: #(a b x y) equals: self getSubmorphNames. morph addAllMorphs: (self getSubmorphs: #(a x)) after: (self getSubmorph: #y). self assert: #(b y a x) equals: self getSubmorphNames. morph addAllMorphs: (self getSubmorphs: #(x y)) after: (self getSubmorph: #a). self assert: #(b a x y) equals: self getSubmorphNames.! ----- Method: MorphTest>>testAddAllMorphsInFrontOf (in category 'testing - add/remove submorphs') ----- testAddAllMorphsInFrontOf self createAndAddMorphs: #(a b). self assert: #(a b) equals: self getSubmorphNames. morph addAllMorphs: (self createMorphs: #(x y)) inFrontOf: (self getSubmorph: #b). self assert: #(a x y b) equals: self getSubmorphNames. morph addAllMorphs: (self getSubmorphs: #(x y)) inFrontOf: (self getSubmorph: #a). self assert: #(x y a b) equals: self getSubmorphNames. morph addAllMorphs: (self getSubmorphs: #(y b)) inFrontOf: (self getSubmorph: #x). self assert: #(y b x a) equals: self getSubmorphNames. morph addAllMorphs: (self getSubmorphs: #(x y)) inFrontOf: (self getSubmorph: #b). self assert: #(x y b a) equals: self getSubmorphNames.! ----- Method: MorphTest>>testIntoWorldCollapseOutOfWorld (in category 'testing - into/outOf World') ----- testIntoWorldCollapseOutOfWorld | m1 m2 collapsed | "Create the guys" m1 := TestInWorldMorph new. m2 := TestInWorldMorph new. self assert: (m1 intoWorldCount = 0). self assert: (m1 outOfWorldCount = 0). self assert: (m2 intoWorldCount = 0). self assert: (m2 outOfWorldCount = 0). "add them to basic morph" morph addMorphFront: m1. m1 addMorphFront: m2. self assert: (m1 intoWorldCount = 0). self assert: (m1 outOfWorldCount = 0). self assert: (m2 intoWorldCount = 0). self assert: (m2 outOfWorldCount = 0). "open the guy" morph openInWorld. self assert: (m1 intoWorldCount = 1). self assert: (m1 outOfWorldCount = 0). self assert: (m2 intoWorldCount = 1). self assert: (m2 outOfWorldCount = 0). "collapse it" collapsed := CollapsedMorph new beReplacementFor: morph. self assert: (m1 intoWorldCount = 1). self assert: (m1 outOfWorldCount = 1). self assert: (m2 intoWorldCount = 1). self assert: (m2 outOfWorldCount = 1). "expand it" collapsed collapseOrExpand. self assert: (m1 intoWorldCount = 2). self assert: (m1 outOfWorldCount = 1). self assert: (m2 intoWorldCount = 2). self assert: (m2 outOfWorldCount = 1). "delete it" morph delete. self assert: (m1 intoWorldCount = 2). self assert: (m1 outOfWorldCount = 2). self assert: (m2 intoWorldCount = 2). self assert: (m2 outOfWorldCount = 2). ! ----- Method: MorphTest>>testIntoWorldDeleteOutOfWorld (in category 'testing - into/outOf World') ----- testIntoWorldDeleteOutOfWorld | m1 m2 | "Create the guys" m1 := TestInWorldMorph new. m2 := TestInWorldMorph new. self assert: (m1 intoWorldCount = 0). self assert: (m1 outOfWorldCount = 0). self assert: (m2 intoWorldCount = 0). self assert: (m2 outOfWorldCount = 0). morph addMorphFront: m1. m1 addMorphFront: m2. self assert: (m1 intoWorldCount = 0). self assert: (m1 outOfWorldCount = 0). self assert: (m2 intoWorldCount = 0). self assert: (m2 outOfWorldCount = 0). morph openInWorld. self assert: (m1 intoWorldCount = 1). self assert: (m1 outOfWorldCount = 0). self assert: (m2 intoWorldCount = 1). self assert: (m2 outOfWorldCount = 0). morph delete. self assert: (m1 intoWorldCount = 1). self assert: (m1 outOfWorldCount = 1). self assert: (m2 intoWorldCount = 1). self assert: (m2 outOfWorldCount = 1). ! ----- Method: MorphTest>>testIntoWorldTransferToNewGuy (in category 'testing - into/outOf World') ----- testIntoWorldTransferToNewGuy | m1 m2 | "Create the guys" m1 := TestInWorldMorph new. m2 := TestInWorldMorph new. self assert: (m1 intoWorldCount = 0). self assert: (m1 outOfWorldCount = 0). self assert: (m2 intoWorldCount = 0). self assert: (m2 outOfWorldCount = 0). morph addMorphFront: m1. m1 addMorphFront: m2. self assert: (m1 intoWorldCount = 0). self assert: (m1 outOfWorldCount = 0). self assert: (m2 intoWorldCount = 0). self assert: (m2 outOfWorldCount = 0). morph openInWorld. self assert: (m1 intoWorldCount = 1). self assert: (m1 outOfWorldCount = 0). self assert: (m2 intoWorldCount = 1). self assert: (m2 outOfWorldCount = 0). morph addMorphFront: m2. self assert: (m1 intoWorldCount = 1). self assert: (m1 outOfWorldCount = 0). self assert: (m2 intoWorldCount = 1). self assert: (m2 outOfWorldCount = 0). morph addMorphFront: m1. self assert: (m1 intoWorldCount = 1). self assert: (m1 outOfWorldCount = 0). self assert: (m2 intoWorldCount = 1). self assert: (m2 outOfWorldCount = 0). m2 addMorphFront: m1. self assert: (m1 intoWorldCount = 1). self assert: (m1 outOfWorldCount = 0). self assert: (m2 intoWorldCount = 1). self assert: (m2 outOfWorldCount = 0). morph delete. self assert: (m1 intoWorldCount = 1). self assert: (m1 outOfWorldCount = 1). self assert: (m2 intoWorldCount = 1). self assert: (m2 outOfWorldCount = 1). ! ----- Method: MorphTest>>testIsMorph (in category 'testing - classification') ----- testIsMorph self assert: (morph isMorph).! ----- Method: MorphTest>>testOpenInWorld (in category 'testing - initialization') ----- testOpenInWorld "This should not throw an exception." morph openInWorld.! MorphTest subclass: #PolygonMorphTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Basic'! !PolygonMorphTest commentStamp: 'nice 2/16/2008 02:13' prior: 0! This class holds tests for PolygonMorph! ----- Method: PolygonMorphTest>>testBoundsBug1035 (in category 'bounds') ----- testBoundsBug1035 "This is a non regression test for http://bugs.squeak.org/view.php?id=1035 PolygonMorph used to position badly when container bounds were growing" | submorph aMorph | submorph := (PolygonMorph vertices: {0@0. 100@0. 0@100} color: Color red borderWidth: 0 borderColor: Color transparent) color: Color red. submorph bounds. "0@0 corner: 100@100" aMorph := Morph new color: Color blue; layoutPolicy: ProportionalLayout new; addMorph: submorph fullFrame: (LayoutFrame fractions: (0.1 @ 0.1 corner: 0.9 @ 0.9)). submorph bounds. "0@0 corner: 100@100 NOT YET UPDATED" aMorph fullBounds. "0@0 corner: 50@40. CORRECT" submorph bounds. "5@4 corner: 45@36 NOW UPDATED OK" aMorph extent: 100@100. submorph bounds. "5@4 corner: 45@36 NOT YET UPDATED" aMorph fullBounds. "-10@-14 corner: 100@100 WRONG" submorph bounds. "-10@-14 corner: 70@66 NOW WRONG POSITION (BUT RIGHT EXTENT)" self assert: aMorph fullBounds = (0 @ 0 extent: 100@100). self assert: submorph bounds = (10 @ 10 corner: 90@90). ! TestCase subclass: #MorphicUIManagerTest instanceVariableNames: 'cases' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-ToolBuilder'! !MorphicUIManagerTest commentStamp: 'wiz 1/3/2007 13:57' prior: 0! A MorphicUIBugTest is a class for testing the shortcomings and repairs of the MorphicUI manager. . Instance Variables cases: <aCollection> cases - a list of morphs that may need to be deleted during teardown. the tests are expected to fill this list it starts out empty by default. ! ----- Method: MorphicUIManagerTest>>defaultTimeout (in category 'as yet unclassified') ----- defaultTimeout ^ 60 "seconds"! ----- Method: MorphicUIManagerTest>>findWindowInWorldLabeled: (in category 'as yet unclassified') ----- findWindowInWorldLabeled: aLabel "Look in the world and in the hand for windows. Yes, windows may spawn in the hand." ^ World submorphs, (World hands gather: [:hand | hand submorphs]) detect: [ :each | (each isKindOf: SystemWindow) and: [ each label = aLabel ] ] ifNone: [].! ----- Method: MorphicUIManagerTest>>setUp (in category 'as yet unclassified') ----- setUp "default. tests will add morphs to list. Teardown will delete." cases := #() .! ----- Method: MorphicUIManagerTest>>tearDown (in category 'as yet unclassified') ----- tearDown "default. tests will add morphs to list. Teardown will delete." cases do: [ :each | each delete ] .! ----- Method: MorphicUIManagerTest>>testOpenWorkspace (in category 'as yet unclassified') ----- testOpenWorkspace "self new testOpenWorkspace" "MorphicUIBugTest run: #testOpenWorkspace" | window myLabel foundWindow myModel | self assert: Smalltalk isMorphic. myLabel := 'Workspace from SUnit test' . foundWindow := self findWindowInWorldLabeled: myLabel . self assert: foundWindow isNil. window := UIManager default edit: '"MorphicUIBugTest run: #openWorkspaceTest"' label: myLabel. window := window. foundWindow := self findWindowInWorldLabeled: myLabel. cases := Array with: foundWindow . "For teardown." myModel := foundWindow submorphs detect: #isMorphicModel. self assert: myModel model class == Workspace. self assert: foundWindow model class == Workspace. foundWindow delete! ----- Method: MorphicUIManagerTest>>testOpenWorkspaceAns (in category 'as yet unclassified') ----- testOpenWorkspaceAns "Test if method opening a workspace answers the window opened" "MorphicUIBugTest run: #testOpenWorkspaceAns" | window myLabel foundWindow | self assert: ( Smalltalk isMorphic ) . myLabel := 'Workspace from ', 'SUnit test' . foundWindow := self findWindowInWorldLabeled: myLabel . self assert: ( foundWindow isNil ) . window := UIManager default edit: '"MorphicUIBugTest run: #openWorkspaceTest"' label: myLabel . foundWindow := self findWindowInWorldLabeled: myLabel . cases := Array with: foundWindow . "For teardown." self assert: ( window == foundWindow ) . foundWindow delete .! ----- Method: MorphicUIManagerTest>>testShowAllBinParts (in category 'as yet unclassified') ----- testShowAllBinParts "self new testShowAllBinParts" "MorphicUIBugTest run: #testShowAllBinParts" self assert: Smalltalk isMorphic. "This should not throw an exception." cases := Array with: ObjectsTool initializedInstance showAll openCenteredInWorld! ----- Method: MorphicUIManagerTest>>testUIManagerNoAcceptInitially (in category 'as yet unclassified') ----- testUIManagerNoAcceptInitially "Ensure that UIManager does not invoke the accept: action initially." | accepted window | accepted := false. window := UIManager default edit: Text new label: 'Test' accept: [:val| accepted := true]. window delete. self deny: accepted.! MorphicUIManagerTest subclass: #StickynessBugz instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Basic'! !StickynessBugz commentStamp: 'wiz 11/24/2006 00:24' prior: 0! A StickynessBugz is for mantis #5500 rectangles and ellipses don't act sticky when rotated even when they are.. Instance Variables ! ----- Method: StickynessBugz>>testForTiltedStickyness (in category 'as yet unclassified') ----- testForTiltedStickyness "self new testForTiltedStickyness" "self run: #testForTiltedStickyness" | m | m := RectangleMorph new openCenteredInWorld . cases := Array with: m . "save for tear down." self assert: ( m topRendererOrSelf isSticky not ) . m beSticky . self assert: ( m topRendererOrSelf isSticky ) . m addFlexShell . cases := Array with: m topRendererOrSelf . m topRendererOrSelf rotationDegrees: 45.0 . self assert: ( m topRendererOrSelf isSticky ) . m beUnsticky . self assert: ( m topRendererOrSelf isSticky not ) . m topRendererOrSelf delete. ^true ! TestCase subclass: #PluggableTextMorphTest instanceVariableNames: 'widget model' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Widgets'! ----- Method: PluggableTextMorphTest>>setUp (in category 'running') ----- setUp super setUp. model := ValueHolder new contents: ''; yourself. widget := PluggableTextMorph on: model text: #contents accept: #contents:.! ----- Method: PluggableTextMorphTest>>test01TextChangeInModel (in category 'tests') ----- test01TextChangeInModel model contents: 'Hello, World!!'. self assert: model contents equals: widget text asString.! ----- Method: PluggableTextMorphTest>>test02TextChangeInWidget (in category 'tests') ----- test02TextChangeInWidget widget replaceSelectionWith: 'Hello, World!!'. self assert: '' equals: model contents. widget accept. self assert: widget text asString equals: model contents asString.! ----- Method: PluggableTextMorphTest>>test03TriggerAcceptFromModel (in category 'tests') ----- test03TriggerAcceptFromModel widget replaceSelectionWith: 'Hello, World!!'. self assert: widget hasUnacceptedEdits. model changed: #acceptChanges. self assert: widget text asString equals: model contents asString.! ----- Method: PluggableTextMorphTest>>test04TriggerAcceptFromWidget (in category 'tests') ----- test04TriggerAcceptFromWidget widget replaceSelectionWith: 'Hello, World!!'. self assert: widget hasUnacceptedEdits. widget accept. self assert: widget text asString equals: model contents asString.! TestCase subclass: #RenderBugz instanceVariableNames: 'cases' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Basic'! !RenderBugz commentStamp: 'fbs 5/8/2013 12:27' prior: 0! A RenderBugz is an infinite recursion bug test for TransformationMorphs. In 3.9 (7067) and before, when TransformationMorph has no rendee there are several methods that will infinitely recurse until manually stopped or the image runs out of memory. So far the ones I've caught are the getters and setters for heading and forwardDirection. So there are tests for them here. Ideally there would be a way to run a test against a stopwatch to catch endless recursion. Found it. Now incorperated. And the tests should be both save to run and cleanup after themselves even when they fail. So far we have not tested the normal cases of rendering working. I will leave that as a separate task for another time. So this is an automatic test when the bugs are fixed and interactive (crash) tests when the bugs are present. Instance Variables Revision notes. wiz 5/15/2008 22:58 When running tests from the TestRunner browser the test would sporadically fail. When they failed a transfomation morph would be left on the screen and not removed by the ensureBlock. So I changed things to fall under MorphicUIBugTests because that had a cleanup mechansizm for left over morphs. I also added one routine to test for time and one parameter to determine the time limit. To my surprise doubling or tripling the time limit still produced sporadic errors when the test is run repeatedly enough ( I am using a 400mz iMac. ) So now the parameter is set to 4. Things will probably fail there if tried long enough. At that point try 5 etc. I am reluctant to make the number larger than necessary. The tighter the test the more you know what is working. I also added a dummy test to check specifically for the timing bug. It fails on the same sporadic basis as the other test went the time parameter is short enough. This lends confidence to the theory that the timing difficulty is coming from outside the test. The sunit runner puts up a progress morph for each test. So the morphic display stuff is busy and probably also the GC. Revision notes. fbs 05/08/2013 12:26 UTC Copied MorphicUIBugTest's setUp/tearDown here because these tests have nothing to do with the MorphicUIManager tests.! ----- Method: RenderBugz>>long (in category 'utility') ----- long "return time limit in milliseconds for tests" ^4! ----- Method: RenderBugz>>setUp (in category 'running') ----- setUp "default. tests will add morphs to list. Teardown will delete." cases := #().! ----- Method: RenderBugz>>shouldntTakeLong: (in category 'utility') ----- shouldntTakeLong: aBlock "Check for infinite recursion. Test should finish in a reasonable time." ^self should: aBlock notTakeMoreThanMilliseconds: self long . ! ----- Method: RenderBugz>>tearDown (in category 'running') ----- tearDown "default. tests will add morphs to list. Teardown will delete." cases do: [ :each | each delete ].! ----- Method: RenderBugz>>testForward (in category 'tests') ----- testForward "If the bug exist there will be an infinte recursion." "self new testForward" "self run: #testForward" | t | cases := { t := TransformationMorph new openCenteredInWorld } . self shouldntTakeLong: [self assert: ( t forwardDirection = 0.0 ) ] . ^true ! ----- Method: RenderBugz>>testHeading (in category 'tests') ----- testHeading "If the bug exist there will be an infinte recursion." "self new testHeading" "self run: #testHeading" | t | cases := { t := TransformationMorph new openCenteredInWorld } . self shouldntTakeLong: [ [self assert: ( t heading = 0.0 ) ] ensure: [ t delete ] ] . ^true ! ----- Method: RenderBugz>>testSetForward (in category 'tests') ----- testSetForward "If the bug exist there will be an infinte reccursion." "self new testSetForward" "self run: #testSetForward" | t | cases := { t := TransformationMorph new openCenteredInWorld } . self shouldntTakeLong: [ t forwardDirection: 180.0 . self assert: ( t forwardDirection = 0.0 ) ] . "and without a rendee it should not change things." ^true ! ----- Method: RenderBugz>>testSetHeading (in category 'tests') ----- testSetHeading "If the bug exist there will be an infinte recursion." "self new testSetHeading" "self run: #testSetHeading" | t | cases := { t := TransformationMorph new openCenteredInWorld } . self shouldntTakeLong: [ t heading: 180 . self assert: ( t heading = 0.0 ) .] . ^true ! ----- Method: RenderBugz>>testTestTime (in category 'tests') ----- testTestTime "This is a control case. Should always pass. If it does not something external to the tests are slowing things down past the 1 millisecond mark." "self new testTestTime" "self run: #testTestTime" | t | cases := { t := TransformationMorph new openCenteredInWorld } . self shouldntTakeLong: [ self assert: ( true ) ] . ^true ! TestCase subclass: #ScrollPaneTest instanceVariableNames: 'sut content' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Widgets'! ScrollPaneTest subclass: #ScrollPaneLeftBarTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Widgets'! ----- Method: ScrollPaneLeftBarTest class>>shouldInheritSelectors (in category 'testing') ----- shouldInheritSelectors ^ true! ----- Method: ScrollPaneLeftBarTest>>setUp (in category 'running') ----- setUp super setUp. sut scrollBarOnLeft: true.! ScrollPaneTest subclass: #ScrollPaneRetractableBarsTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Widgets'! ----- Method: ScrollPaneRetractableBarsTest class>>shouldInheritSelectors (in category 'testing') ----- shouldInheritSelectors ^ true! ----- Method: ScrollPaneRetractableBarsTest>>setUp (in category 'running') ----- setUp super setUp. sut retractable: true.! ----- Method: ScrollPaneRetractableBarsTest>>test01ScrollBarPolicyWhenNeeded (in category 'tests') ----- test01ScrollBarPolicyWhenNeeded sut hScrollBarPolicy: #whenNeeded; vScrollBarPolicy: #whenNeeded. content extent: 100@100. self refresh. self deny: sut hIsScrollbarShowing; deny: sut vIsScrollbarShowing. content extent: 150@150. self refresh. self deny: sut hIsScrollbarShowing; deny: sut vIsScrollbarShowing.! ----- Method: ScrollPaneRetractableBarsTest>>test02ScrollBarPolicyAlways (in category 'tests') ----- test02ScrollBarPolicyAlways sut hScrollBarPolicy: #always; vScrollBarPolicy: #always. content extent: 50@50. self refresh. self deny: sut hIsScrollbarShowing; deny: sut vIsScrollbarShowing. content extent: 150@150. self refresh. self deny: sut hIsScrollbarShowing; deny: sut vIsScrollbarShowing.! ----- Method: ScrollPaneRetractableBarsTest>>test06ScrollRanges (in category 'tests') ----- test06ScrollRanges content extent: 200@300. self refresh. self assert: 200 equals: sut hTotalScrollRange; assert: 300 equals: sut vTotalScrollRange; assert: 100 equals: sut hLeftoverScrollRange; assert: 200 equals: sut vLeftoverScrollRange. sut hScrollBarValue: 50. sut vScrollBarValue: 30. "Scrolling does not affect the scroll ranges." self assert: 200 equals: sut hTotalScrollRange; assert: 300 equals: sut vTotalScrollRange; assert: 100 equals: sut hLeftoverScrollRange; assert: 200 equals: sut vLeftoverScrollRange.! ----- Method: ScrollPaneRetractableBarsTest>>test08ScrollToShow (in category 'tests') ----- test08ScrollToShow content extent: 300@300. self refresh. "1a) Scroll down/right to show bottom right corner." self scrollToTopLeft. sut scrollToShow: (50@50 corner: 100@100). self assert: 0@0 equals: sut scroller offset. "1b) Scroll up/left to show top left corner." self scrollToBottomRight. sut scrollToShow: (100@100 corner: 150@150). self assert: 100@100 equals: sut scroller offset. "2a) Too big, so show bottom right corner because we scroll down/right." self scrollToTopLeft. sut scrollToShow: (0@0 corner: 100@100). self assert: 0@0 equals: sut scroller offset. "2b) Too big, so show top left corner because we scroll up/left." self scrollToBottomRight. sut scrollToShow: (50@50 corner: 150@150). self assert: 50@50 equals: sut scroller offset. "3) No negative offsets." self scrollToTopLeft. sut scrollToShow: (-10 @ -10 corner: 50@50). self assert: 0@0 equals: sut scroller offset.! ----- Method: ScrollPaneTest>>refresh (in category 'running') ----- refresh "Since there is now direct communication between the content and the scroll pane, re-layouting as to be explicit." sut resizeScrollBars; resizeScroller; setScrollDeltas. ! ----- Method: ScrollPaneTest>>scrollToBottomRight (in category 'running') ----- scrollToBottomRight sut hScrollBar setValue: sut hScrollBar maximumValue. sut vScrollBar setValue: sut vScrollBar maximumValue.! ----- Method: ScrollPaneTest>>scrollToTopLeft (in category 'running') ----- scrollToTopLeft sut hScrollBarValue: 0; vScrollBarValue: 0; setScrollDeltas.! ----- Method: ScrollPaneTest>>setUp (in category 'running') ----- setUp super setUp. sut := ScrollPane new. sut retractable: false; scrollBarOnLeft: false; extent: 100@100; borderWidth: 0. "Very important for the math in tests!!" content := Morph new. sut scroller addMorph: content.! ----- Method: ScrollPaneTest>>test00SetUp (in category 'tests') ----- test00SetUp self assert: 100@100 equals: sut extent.! ----- Method: ScrollPaneTest>>test01ScrollBarPolicyWhenNeeded (in category 'tests') ----- test01ScrollBarPolicyWhenNeeded sut hScrollBarPolicy: #whenNeeded; vScrollBarPolicy: #whenNeeded. content extent: 100@100. self refresh. self deny: sut hIsScrollbarShowing; deny: sut vIsScrollbarShowing. content extent: 150@150. self refresh. self assert: sut hIsScrollbarShowing; assert: sut vIsScrollbarShowing.! ----- Method: ScrollPaneTest>>test02ScrollBarPolicyAlways (in category 'tests') ----- test02ScrollBarPolicyAlways sut hScrollBarPolicy: #always; vScrollBarPolicy: #always. content extent: 50@50. self refresh. self assert: sut hIsScrollbarShowing; assert: sut vIsScrollbarShowing. content extent: 150@150. self refresh. self assert: sut hIsScrollbarShowing; assert: sut vIsScrollbarShowing.! ----- Method: ScrollPaneTest>>test03ScrollBarPolicyNever (in category 'tests') ----- test03ScrollBarPolicyNever sut hScrollBarPolicy: #never; vScrollBarPolicy: #never. content extent: 50@50. self refresh. self deny: sut hIsScrollbarShowing; deny: sut vIsScrollbarShowing. content extent: 150@150. self refresh. self deny: sut hIsScrollbarShowing; deny: sut vIsScrollbarShowing.! ----- Method: ScrollPaneTest>>test04ScrollingCallIn (in category 'tests') ----- test04ScrollingCallIn content extent: 200@200. self refresh. self assert: 0 equals: sut hScrollBar value; assert: 0 equals: sut vScrollBar value; assert: 0@0 equals: sut scroller offset. sut hScrollBar setValue: 50. sut vScrollBar setValue: 50. self assert: 50 equals: sut hScrollBar value; assert: 50 equals: sut vScrollBar value; assert: 50@50 equals: sut scroller offset. ! ----- Method: ScrollPaneTest>>test05ScrollingCallOut (in category 'tests') ----- test05ScrollingCallOut "There is no automatic call-out from pane to scroll bars yet." content extent: 200@200. self refresh. self assert: 0 equals: sut hScrollBar value; assert: 0 equals: sut vScrollBar value; assert: 0@0 equals: sut scroller offset. sut hScrollBarValue: 50. sut vScrollBarValue: 50. self assert: 0 equals: sut hScrollBar value; assert: 0 equals: sut vScrollBar value; assert: 50@50 equals: sut scroller offset. sut hSetScrollDelta. sut vSetScrollDelta. self assert: 50 equals: sut hScrollBar value; assert: 50 equals: sut vScrollBar value.! ----- Method: ScrollPaneTest>>test06ScrollRanges (in category 'tests') ----- test06ScrollRanges content extent: 200@300. self refresh. self assert: 200 equals: sut hTotalScrollRange; assert: 300 equals: sut vTotalScrollRange; assert: 100 equals: sut hLeftoverScrollRange - sut scrollBarThickness; assert: 200 equals: sut vLeftoverScrollRange - sut scrollBarThickness. sut hScrollBarValue: 50. sut vScrollBarValue: 30. "Scrolling does not affect the scroll ranges." self assert: 200 equals: sut hTotalScrollRange; assert: 300 equals: sut vTotalScrollRange; assert: 100 equals: sut hLeftoverScrollRange - sut scrollBarThickness; assert: 200 equals: sut vLeftoverScrollRange - sut scrollBarThickness. ! ----- Method: ScrollPaneTest>>test07GuardOffsets (in category 'tests') ----- test07GuardOffsets "Scroll bars will never report negative values because they have 0 as minimum. Programmatic access, however, might provide those. Visual appearance should not break then." content extent: 200@300. self refresh. sut hScrollBarValue: -10. sut vScrollBarValue: -20. self assert: 0@0 equals: sut scroller offset.! ----- Method: ScrollPaneTest>>test08ScrollToShow (in category 'tests') ----- test08ScrollToShow content extent: 300@300. self refresh. "1a) Scroll down/right to show bottom right corner." self scrollToTopLeft. sut scrollToShow: (50@50 corner: 100@100). self assert: (sut scrollBarThickness @ sut scrollBarThickness) equals: sut scroller offset. "1b) Scroll up/left to show top left corner." self scrollToBottomRight. sut scrollToShow: (100@100 corner: 150@150). self assert: 100@100 equals: sut scroller offset. "2a) Too big, so show bottom right corner because we scroll down/right." self scrollToTopLeft. sut scrollToShow: (0@0 corner: 100@100). self assert: (sut scrollBarThickness @ sut scrollBarThickness) equals: sut scroller offset. "2b) Too big, so show top left corner because we scroll up/left." self scrollToBottomRight. sut scrollToShow: (50@50 corner: 150@150). self assert: 50@50 equals: sut scroller offset. "3) No negative offsets." self scrollToTopLeft. sut scrollToShow: (-10 @ -10 corner: 50@50). self assert: 0@0 equals: sut scroller offset.! ----- Method: ScrollPaneTest>>test09HideShowTransition (in category 'tests') ----- test09HideShowTransition content extent: 300@300. self refresh. "1) Horizontal bar not needed anymore." sut extent: 100@100. sut vScrollBar setValue: 50. sut width: content width + sut vScrollBar width. self assert: sut vLeftoverScrollRange equals: sut vScrollBar maximumValue. "2) Vertical bar not needed anymore." sut extent: 100@100. sut hScrollBar setValue: 50. sut height: content height + sut hScrollBar height. self assert: sut hLeftoverScrollRange equals: sut hScrollBar maximumValue. ! TestCase subclass: #SliderTest instanceVariableNames: 'sut' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Widgets'! SliderTest subclass: #ScrollBarTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Widgets'! ----- Method: ScrollBarTest class>>shouldInheritSelectors (in category 'testing') ----- shouldInheritSelectors ^ true! ----- Method: ScrollBarTest>>subjectClass (in category 'running') ----- subjectClass ^ ScrollBar! ----- Method: SliderTest>>setUp (in category 'running') ----- setUp super setUp. sut := self subjectClass on: (ValueHolder new contents: 0.0) getValue: #contents setValue: #contents:. sut extent: 400@20.! ----- Method: SliderTest>>subjectClass (in category 'running') ----- subjectClass ^ Slider! ----- Method: SliderTest>>test01Value (in category 'tests') ----- test01Value self assert: 0.0 equals: sut value. self assert: 0.0 equals: sut model contents.! ----- Method: SliderTest>>test02SetValue (in category 'tests') ----- test02SetValue sut setValue: 0.5. self assert: 0.5 equals: sut value; assert: 0.5 equals: sut model contents.! ----- Method: SliderTest>>test03MinMax (in category 'tests') ----- test03MinMax sut minimumValue: 10; maximumValue: 20. sut setValue: 5. self assert: 10 equals: sut value truncated. sut setValue: 30. self assert: 20 equals: sut value truncated. sut maximumValue: 15. self assert: 15 equals: sut value truncated. sut setValue: 10. sut minimumValue: 12. self assert: 12 equals: sut value truncated. ! ----- Method: SliderTest>>test04Descending (in category 'tests') ----- test04Descending | px | sut setValue: 0.3. px := sut thumb position. sut descending: sut descending not. self assert: px ~= sut thumb position.! ----- Method: SliderTest>>test05SliderWithoutModel (in category 'tests') ----- test05SliderWithoutModel | swm | swm := Slider new. self assert: 0.0 equals: swm value. swm setValue: 0.6. self assert: 0.6 equals: swm value.! ----- Method: SliderTest>>test06Truncate (in category 'tests') ----- test06Truncate self assert: sut truncate not. sut maximumValue: 100. sut truncate: true. sut setValue: 23.45. self assert: 23 equals: sut value. sut setValue: 23.65. self assert: 24 equals: sut value.! ----- Method: SliderTest>>test07Quantum (in category 'tests') ----- test07Quantum sut maximumValue: 100. sut quantum: 5. sut setValue: 23. self assert: 25 equals: sut value.! ----- Method: SliderTest>>test08MinEqualsMax (in category 'tests') ----- test08MinEqualsMax sut maximumValue: 50; minimumValue: 50. self assert: 50 equals: sut value.! ----- Method: SliderTest>>test09SliderWithoutGetter (in category 'tests') ----- test09SliderWithoutGetter sut getValueSelector: nil. sut setValue: 0.5. self assert: 0.5 equals: sut value. self assert: 0.5 equals: sut model contents.! TestCase subclass: #TextEditorTest instanceVariableNames: 'model widget' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Text Support'! ----- Method: TextEditorTest>>editor (in category 'running') ----- editor ^ widget textMorph editor! ----- Method: TextEditorTest>>setUp (in category 'running') ----- setUp super setUp. model := MorphicTestTextModel new. widget := PluggableTextMorph on: model text: #contents accept: #contents:. "We don't do real keyboard event handling. To be sure to set the model in the editor." self editor model: model. model contents: ''.! ----- Method: TextEditorTest>>test01Setup (in category 'tests') ----- test01Setup self assert: model dependents size = 1. self assert: self editor model == model. self assert: widget text isEmpty. self assert: model contents isEmpty.! ----- Method: TextEditorTest>>test02EvaluateExpression (in category 'tests') ----- test02EvaluateExpression model := MorphicTestTextModelWithEvaluationSupport new. widget model: model. self text: '3+4'. self editor doIt. self assert: (model hasFlag: #expressionEvaluated); assert: 7 equals: model result.! ----- Method: TextEditorTest>>test03DebugExpression (in category 'tests') ----- test03DebugExpression self text: 'Morph new'. self editor debugIt. self assert: (model hasFlag: #expressionDebugged); assert: (model result isKindOf: Morph).! ----- Method: TextEditorTest>>test04PrintIt (in category 'tests') ----- test04PrintIt self text: '3+4'. self editor printIt. self assert: (model hasFlag: #printed); assert: '7' equals: model result.! ----- Method: TextEditorTest>>test05ExploreIt (in category 'tests') ----- test05ExploreIt self text: '1@1 corner: 20@20'. self editor exploreIt. self assert: (model hasFlag: #explored); assert: (model result isKindOf: Rectangle).! ----- Method: TextEditorTest>>test06InspectIt (in category 'tests') ----- test06InspectIt self text: '1@1 corner: 20@20'. self editor inspectIt. self assert: (model hasFlag: #inspected); assert: (model result isKindOf: Rectangle).! ----- Method: TextEditorTest>>test07DoItReceiver (in category 'tests') ----- test07DoItReceiver self text: 'self color'. model result: (Morph new color: Color yellow). self editor doIt. self assert: (model hasFlag: #expressionEvaluated); assert: Color yellow equals: model result.! ----- Method: TextEditorTest>>text: (in category 'running') ----- text: aString "Text editors have a short lifetime in pluggable text morphs." model contents: aString. "We don't do real keyboard event handling. To be sure to set the model in the editor." self editor model: model.! TestCase subclass: #UnimplementedCallBugz instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Basic'! ----- Method: UnimplementedCallBugz>>testPolyIntersect (in category 'as yet unclassified') ----- testPolyIntersect "self run: #testPolyIntersect" "This should not throw an exception." PolygonMorph initializedInstance intersects: ( Rectangle center: Display center extent: 100 asPoint ).! ClassTestCase subclass: #PasteUpMorphTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Worlds'! !PasteUpMorphTest commentStamp: '<historical>' prior: 0! I am a TestCase for PasteUpMorph.! ----- Method: PasteUpMorphTest>>testCursorWrapped (in category 'tests') ----- testCursorWrapped "self debug: #testCursorWrapped" | holder | holder := PasteUpMorph new. self assert: holder cursor = 1. holder cursorWrapped: 2. self assert: holder cursor = 1. holder addMorph: Morph new; addMorph: Morph new; addMorph: Morph new. holder cursorWrapped: 3. self assert: holder cursor = 3. holder cursorWrapped: 5. self assert: holder cursor = 2. holder cursorWrapped: 0. self assert: holder cursor = 3. holder cursorWrapped: -1. self assert: holder cursor = 2.! ----- Method: PasteUpMorphTest>>testCursorWrappedWithFraction (in category 'tests') ----- testCursorWrappedWithFraction "self debug: #testCursorWrappedWithFraction" | holder | holder := PasteUpMorph new. holder addMorph: Morph new; addMorph: Morph new; addMorph: Morph new. holder cursorWrapped: 3.5. self assert: holder cursor = 3.5. holder cursorWrapped: 5.5. self assert: holder cursor = 2.5. holder cursorWrapped: 0.5. self assert: holder cursor = 3.5. holder cursorWrapped: -0.5. self assert: holder cursor = 2.5.! ----- Method: PasteUpMorphTest>>testGridToGradient (in category 'tests') ----- testGridToGradient "A trivial test for checking that you can change from a grid to a gradient background. A recent [FIX] will make this pass." | pum | pum := PasteUpMorph new. pum setStandardTexture. "The following should fail without the fix" self shouldnt: [pum gradientFillColor: Color red] raise: MessageNotUnderstood! ----- Method: PasteUpMorphTest>>testPlayWithMe1Romoval (in category 'tests') ----- testPlayWithMe1Romoval "A trivial test for checking that PlayWithMe classes are all removed" self deny: ( Smalltalk hasClassNamed: 'PlayWithMe1' ) .! ClassTestCase subclass: #SimpleSwitchMorphTest instanceVariableNames: 'testSwitch' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Widgets'! !SimpleSwitchMorphTest commentStamp: '<historical>' prior: 0! I test the behavior of SimpleSwitchMorph! ----- Method: SimpleSwitchMorphTest>>classToBeTested (in category 'as yet unclassified') ----- classToBeTested ^ SimpleSwitchMorph ! ----- Method: SimpleSwitchMorphTest>>setUp (in category 'as yet unclassified') ----- setUp super setUp. testSwitch := SimpleSwitchMorph new! ----- Method: SimpleSwitchMorphTest>>testName (in category 'as yet unclassified') ----- testName self assert: testSwitch externalName = 'SimpleSwitch'! ----- Method: SimpleSwitchMorphTest>>testState (in category 'as yet unclassified') ----- testState self assert: testSwitch isOff. self deny: testSwitch isOn. testSwitch toggleState. self assert: testSwitch isOn. self deny: testSwitch isOff! ----- Method: SimpleSwitchMorphTest>>testSwitching (in category 'as yet unclassified') ----- testSwitching testSwitch setSwitchState: false. self assert: testSwitch isOff. self assert: testSwitch color = testSwitch offColor. testSwitch setSwitchState: true. self assert: testSwitch isOn. self assert: testSwitch color = testSwitch onColor.! ClassTestCase subclass: #TextMorphTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Basic'! ----- Method: TextMorphTest>>testInitialize (in category 'testing') ----- testInitialize "For now, just make sure initialization doesn't throw exception" TextMorph initialize.! ClassTestCase subclass: #WorldStateTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Worlds'! ----- Method: WorldStateTest>>testDeferredUIQueueTimeout (in category 'tests') ----- testDeferredUIQueueTimeout "Ensure that the World's deferredUIMessage will take no more time than specified by WorldState's deferredExecutionTimeLimit" | firstWasRun secondWasRun thirdWasRun | firstWasRun := secondWasRun := thirdWasRun := false. WorldState addDeferredUIMessage:[ firstWasRun := true. (Delay forMilliseconds: WorldState deferredExecutionTimeLimit + 50) wait. ]. WorldState addDeferredUIMessage:[ secondWasRun := true. ]. WorldState addDeferredUIMessage:[ thirdWasRun := true. ]. self deny: firstWasRun. self deny: secondWasRun. self deny: thirdWasRun. World doOneCycleNow. self assert: firstWasRun. self deny: secondWasRun. self deny: thirdWasRun. World doOneCycleNow. self assert: firstWasRun. self assert: secondWasRun. self assert: thirdWasRun. !

1 0

Squeak 4.6: ToolBuilder-MVC-mt.42.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of ToolBuilder-MVC to project Squeak 4.6: http://source.squeak.org/squeak46/ToolBuilder-MVC-mt.42.mcz ==================== Summary ==================== Name: ToolBuilder-MVC-mt.42 Author: mt Time: 3 May 2015, 3:14:38.18 pm UUID: f1b2eb4e-2140-c445-a31f-c4c95ad44334 Ancestors: ToolBuilder-MVC-mt.41 A simple implementation for spacers. ==================== Snapshot ==================== SystemOrganization addCategory: #'ToolBuilder-MVC'! ToolBuilder subclass: #MVCToolBuilder instanceVariableNames: 'panes topSize widgets parentMenu' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-MVC'! !MVCToolBuilder commentStamp: 'ar 2/11/2005 15:02' prior: 0! The MVC tool builder.! ----- Method: MVCToolBuilder class>>isActiveBuilder (in category 'accessing') ----- isActiveBuilder "Answer whether I am the currently active builder" "This is really a way of answering whether 'Smalltalk isMVC'" ScheduledControllers ifNil:[^false]. ^(ScheduledControllers activeControllerProcess ifNil:[^false]) isTerminated not! ----- Method: MVCToolBuilder>>asWindow: (in category 'private') ----- asWindow: aRectangle | outer | outer := parent window ifNil: [topSize]. ^(aRectangle origin * outer extent) truncated corner: (aRectangle corner * outer extent) truncated! ----- Method: MVCToolBuilder>>buildPluggableAlternateMultiSelectionList: (in category 'widgets optional') ----- buildPluggableAlternateMultiSelectionList: aSpec "Trim selector to one argument to match list expectations." aSpec setIndex: (aSpec setIndex first: (aSpec setIndex findString: ':')) asSymbol. ^ self buildPluggableList: aSpec.! ----- Method: MVCToolBuilder>>buildPluggableButton: (in category 'widgets required') ----- buildPluggableButton: aSpec | widget label state | label := aSpec label. state := aSpec state. widget := PluggableButtonView on: aSpec model getState: (state isSymbol ifTrue:[state]) action: aSpec action label: (label isSymbol ifTrue:[label]). self register: widget id: aSpec name. label ifNotNil: [label isSymbol ifTrue: [widget label: (aSpec model perform: label)] ifFalse: [widget label: label]]. self setFrame: aSpec frame in: widget. parent ifNotNil: [parent addSubView: widget]. ^widget! ----- Method: MVCToolBuilder>>buildPluggableList: (in category 'widgets required') ----- buildPluggableList: aSpec | widget listClass getIndex setIndex | aSpec getSelected ifNil:[ listClass := PluggableListView. getIndex := aSpec getIndex. setIndex := aSpec setIndex. ] ifNotNil:[ listClass := PluggableListViewByItem. getIndex := aSpec getSelected. setIndex := aSpec setSelected. ]. widget := listClass on: aSpec model list: aSpec list selected: getIndex changeSelected: setIndex menu: aSpec menu keystroke: aSpec keyPress. self register: widget id: aSpec name. self setFrame: aSpec frame in: widget. parent ifNotNil:[parent addSubView: widget]. panes ifNotNil:[ aSpec list ifNotNil:[panes add: aSpec list]. ]. ^widget! ----- Method: MVCToolBuilder>>buildPluggableMenu: (in category 'widgets required') ----- buildPluggableMenu: menuSpec "Just a very simple mapping to selection menu. It assumes that all item specs have the same receiver." | menu | menu := CustomMenu new. menuSpec items do: [:ea | menu add: ea label target: ea action receiver selector: ea action selector argumentList: ea action arguments. ea separator ifTrue: [menu addLine]]. ^ menu! ----- Method: MVCToolBuilder>>buildPluggableMenuItem: (in category 'widgets required') ----- buildPluggableMenuItem: itemSpec ^ itemSpec label! ----- Method: MVCToolBuilder>>buildPluggablePanel: (in category 'widgets required') ----- buildPluggablePanel: aSpec | widget children | widget := View new model: aSpec model. widget borderWidth: 1. self register: widget id: aSpec name. children := aSpec children. children isSymbol ifTrue:[ "@@@@ FIXME: PluggablePanes need to remember their getChildrenSelector" "widget getChildrenSelector: children. widget update: children." children := #(). ]. self setFrame: aSpec frame in: widget. self buildAll: children in: widget. parent ifNotNil:[parent addSubView: widget]. self setLayout: aSpec layout in: widget. ^widget! ----- Method: MVCToolBuilder>>buildPluggableSpacer: (in category 'widgets required') ----- buildPluggableSpacer: aSpec | widget | widget := View new. self register: widget id: aSpec name. widget borderWidth: 0. widget backgroundColor: aSpec color. widget window: (widget window topLeft extent: aSpec extent). self setFrame: aSpec frame in: widget. parent ifNotNil:[parent addSubView: widget]. ^widget! ----- Method: MVCToolBuilder>>buildPluggableText: (in category 'widgets required') ----- buildPluggableText: aSpec | widget | widget := PluggableTextView on: aSpec model text: aSpec getText accept: aSpec setText readSelection: aSpec selection menu: aSpec menu. self register: widget id: aSpec name. self setFrame: aSpec frame in: widget. parent ifNotNil:[parent addSubView: widget]. panes ifNotNil:[ aSpec getText ifNotNil:[panes add: aSpec getText]. ]. ^widget! ----- Method: MVCToolBuilder>>buildPluggableTree: (in category 'widgets required') ----- buildPluggableTree: aSpec self shouldBeImplemented.! ----- Method: MVCToolBuilder>>buildPluggableWindow: (in category 'widgets required') ----- buildPluggableWindow: aSpec | widget children label | topSize := 0@0 corner: 640@480. aSpec layout == #proportional ifFalse:[ "This needs to be implemented - probably by adding a single pane and then the rest" ^self error: 'Not implemented'. ]. widget := StandardSystemView new. self register: widget id: aSpec name. widget model: aSpec model. label := aSpec label. label isSymbol ifTrue: [label := aSpec model perform: label]. label isNil ifFalse: [widget setLabel: label]. children := aSpec children. children isSymbol ifTrue:[ "This isn't implemented by StandardSystemView, so we fake it" children := widget model perform: children. ]. aSpec extent ifNotNil:[topSize := 0@0 extent: aSpec extent]. widget window: topSize. panes := OrderedCollection new. self buildAll: children in: widget. widget setUpdatablePanesFrom: panes. ^widget! ----- Method: MVCToolBuilder>>close: (in category 'opening') ----- close: aWidget "Close a previously opened widget" aWidget controller closeAndUnschedule.! ----- Method: MVCToolBuilder>>open: (in category 'opening') ----- open: anObject "Build and open the object. Answer the widget opened." | window | window := (anObject isKindOf: View) ifTrue: [anObject] ifFalse: [self build: anObject]. (window isKindOf: PopUpMenu) ifTrue: [window invokeOn: nil]. (window isKindOf: View) ifTrue: [window controller open]. ^window! ----- Method: MVCToolBuilder>>open:label: (in category 'opening') ----- open: anObject label: aString "Build an open the object, labeling it appropriately. Answer the widget opened." | window | window := self build: anObject. window label: aString. window controller open. ^window! ----- Method: MVCToolBuilder>>openDebugger: (in category 'opening') ----- openDebugger: anObject "Build and open the object. Answer the widget opened." | window | window := self build: anObject. window controller openNoTerminate. ^window! ----- Method: MVCToolBuilder>>openDebugger:label: (in category 'opening') ----- openDebugger: anObject label: aString "Build an open the object, labeling it appropriately. Answer the widget opened." | window | window := self build: anObject. window label: aString. window controller openNoTerminate. ^window! ----- Method: MVCToolBuilder>>openDebugger:label:closing: (in category 'opening') ----- openDebugger: anObject label: aString closing: topView "Build an open the object, labeling it appropriately. Answer the widget opened." | window | topView controller controlTerminate. topView deEmphasize; erase. "a few hacks to get the scroll selection artifacts out when we got here by clicking in the list" " topView subViewWantingControl ifNotNil: [ topView subViewWantingControl controller controlTerminate ]." topView controller status: #closed. window := self build: anObject. window label: aString. window controller openNoTerminate. topView controller closeAndUnscheduleNoErase. Processor terminateActive. ^window! ----- Method: MVCToolBuilder>>positionSubviewsWithin: (in category 'private') ----- positionSubviewsWithin: widget "Translate subviews to position the viewport of each subView relative to the widget window origin. If subviews are repositioned, as in a row of button views arranged within a view, then the transformations will later be rescaled to fit the subviews within the widget window." widget subViews ifNotNilDo: [:subViews | subViews isEmpty ifFalse: [ | translation | translation := widget window origin - subViews first window origin. subViews do: [:v | v setTransformation: (v transformation translateBy: translation)]]]. ! ----- Method: MVCToolBuilder>>register:id: (in category 'private') ----- register: widget id: id id ifNil:[^self]. widgets ifNil:[widgets := Dictionary new]. widgets at: id put: widget.! ----- Method: MVCToolBuilder>>runModal: (in category 'opening') ----- runModal: aWidget "Run the (previously opened) widget modally, e.g., do not return control to the sender before the user has responded." ! ----- Method: MVCToolBuilder>>setFrame:in: (in category 'private') ----- setFrame: fractionsRectangleOrLayoutFrame in: widget | win | fractionsRectangleOrLayoutFrame ifNil: [^nil]. win := fractionsRectangleOrLayoutFrame isRectangle ifTrue: [self asWindow: fractionsRectangleOrLayoutFrame] ifFalse: [fractionsRectangleOrLayoutFrame layout: nil in: topSize]. "assume LayoutFrame" widget window: win.! ----- Method: MVCToolBuilder>>setLayout:in: (in category 'private') ----- setLayout: layout in: widget "Arrange subview horizontally or vertically according to layout directive. If the subview dimensions were specified with layout frames rather than explicit rectangle sizes, then their window horizontal or vertical dimensions will be resized as needed to fit within the widget extent." self positionSubviewsWithin: widget. layout == #proportional ifTrue:[^self]. layout == #horizontal ifTrue:[ | prev subViewWidth widgetWidth xScale | subViewWidth := (widget subViews collect: [:e | e window extent x]) sum. widgetWidth := widget window extent x. xScale := widgetWidth / subViewWidth. "to adjust corner of prev prior to align:" prev := nil. widget subViews do:[:next| | newWindowWidth newCorner | prev ifNotNil:[ "resize prev window prior to aligning next" xScale < 1 ifTrue: [ "proportional placement spec requires resizing" newWindowWidth := (prev window extent x * xScale) truncated. newCorner := (prev window origin x + newWindowWidth)@(prev window corner y). prev setWindow: (prev window origin corner: newCorner)]. next align: next viewport topLeft with: prev viewport topRight. ]. prev := next. ]. ^self]. layout == #vertical ifTrue:[ | prev subViewHeight widgetHeight yScale | subViewHeight := (widget subViews collect: [:e | e window extent y]) sum. widgetHeight := widget window extent y. yScale := widgetHeight / subViewHeight. "to adjust corner of prev prior to align:" prev := nil. widget subViews do:[:next| | newWindowHeight newCorner | prev ifNotNil:[ "resize prev window prior to aligning next" yScale < 1 ifTrue: [ "proportional placement spec requires resizing" newWindowHeight := (prev window extent y * yScale) truncated. newCorner := (prev window corner x)@(prev window origin y + newWindowHeight). prev setWindow: (prev window origin corner: newCorner)]. next align: next viewport topLeft with: prev viewport bottomLeft. ]. prev := next. ]. ^self]. ^self error: 'Unknown layout: ', layout.! ----- Method: MVCToolBuilder>>widgetAt:ifAbsent: (in category 'private') ----- widgetAt: id ifAbsent: aBlock widgets ifNil:[^aBlock value]. ^widgets at: id ifAbsent: aBlock! UIManager subclass: #MVCUIManager instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-MVC'! !MVCUIManager commentStamp: 'dtl 5/2/2010 16:06' prior: 0! MVCUIManager is a UIManager that implements user interface requests for an MVC user interface.! ----- Method: MVCUIManager class>>isActiveManager (in category 'accessing') ----- isActiveManager "Answer whether I should act as the active ui manager" "This is really a way of answering whether 'Smalltalk isMVC'" ScheduledControllers ifNil:[^false]. ^ScheduledControllers activeControllerProcess == Processor activeProcess! ----- Method: MVCUIManager>>chooseDirectory:from: (in category 'ui requests') ----- chooseDirectory: label from: dir "Let the user choose a directory" ^self notYetImplemented! ----- Method: MVCUIManager>>chooseFileMatching:label: (in category 'ui requests') ----- chooseFileMatching: patterns label: labelString "Let the user choose a file matching the given patterns" ^self notYetImplemented! ----- Method: MVCUIManager>>chooseFont:for:setSelector:getSelector: (in category 'ui requests') ----- chooseFont: aPrompt for: aTarget setSelector: setSelector getSelector: getSelector "MVC Only!! prompt for a font and if one is provided, send it to aTarget using a message with selector aSelector." | aMenu aChoice aStyle namesAndSizes aFont | aMenu := CustomMenu new. TextStyle actualTextStyles keysSortedSafely do: [:styleName | aMenu add: styleName action: styleName]. aChoice := aMenu startUpWithCaption: aPrompt. aChoice ifNil: [^ self]. aMenu := CustomMenu new. aStyle := TextStyle named: aChoice. (namesAndSizes := aStyle fontNamesWithPointSizes) do: [:aString | aMenu add: aString action: aString]. aChoice := aMenu startUpWithCaption: nil. aChoice ifNil: [^ self]. aFont := aStyle fontAt: (namesAndSizes indexOf: aChoice). aTarget perform: setSelector with: aFont! ----- Method: MVCUIManager>>chooseFrom:lines:title: (in category 'ui requests') ----- chooseFrom: aList lines: linesArray title: aString "Choose an item from the given list. Answer the index of the selected item." | menu | menu := PopUpMenu labelArray: aList lines: linesArray. ^aString isEmpty ifTrue:[menu startUp] ifFalse:[menu startUpWithCaption: aString]! ----- Method: MVCUIManager>>chooseFrom:values:lines:title: (in category 'ui requests') ----- chooseFrom: labelList values: valueList lines: linesArray title: aString "Choose an item from the given list. Answer the selected item." | menu | menu := SelectionMenu labels: labelList lines: linesArray selections: valueList. ^aString isEmpty ifTrue:[menu startUp] ifFalse:[menu startUpWithCaption: aString]! ----- Method: MVCUIManager>>confirm: (in category 'ui requests') ----- confirm: queryString "Put up a yes/no menu with caption queryString. Answer true if the response is yes, false if no. This is a modal question--the user must respond yes or no." ^PopUpMenu confirm: queryString! ----- Method: MVCUIManager>>confirm:orCancel: (in category 'ui requests') ----- confirm: aString orCancel: cancelBlock "Put up a yes/no/cancel menu with caption aString. Answer true if the response is yes, false if no. If cancel is chosen, evaluate cancelBlock. This is a modal question--the user must respond yes or no." ^PopUpMenu confirm: aString orCancel: cancelBlock! ----- Method: MVCUIManager>>confirm:orCancel:title: (in category 'ui requests') ----- confirm: aString orCancel: cancelBlock title: titleString "Put up a yes/no/cancel menu with caption aString, and titleString to label the dialog. Answer true if the response is yes, false if no. If cancel is chosen, evaluate cancelBlock. This is a modal question--the user must respond yes or no." ^ PopUpMenu confirm: (self dialogStringFromQuery: aString withTitle: titleString) orCancel: cancelBlock! ----- Method: MVCUIManager>>confirm:title: (in category 'ui requests') ----- confirm: queryString title: titleString "Put up a yes/no menu with caption queryString, and titleString to label the dialog. Answer true if the response is yes, false if no. This is a modal question--the user must respond yes or no." ^PopUpMenu confirm: (self dialogStringFromQuery: queryString withTitle: titleString) ! ----- Method: MVCUIManager>>confirm:title:trueChoice:falseChoice: (in category 'ui requests') ----- confirm: queryString title: titleString trueChoice: trueChoice falseChoice: falseChoice "Put up a yes/no menu with caption queryString, and titleString to label the dialog. The actual wording for the two choices will be as provided in the trueChoice and falseChoice parameters. Answer true if the response is the true-choice, false if it is the false-choice. This is a modal question -- the user must respond one way or the other." ^ PopUpMenu confirm: (self dialogStringFromQuery: queryString withTitle: titleString) trueChoice: trueChoice falseChoice: falseChoice! ----- Method: MVCUIManager>>confirm:trueChoice:falseChoice: (in category 'ui requests') ----- confirm: queryString trueChoice: trueChoice falseChoice: falseChoice "Put up a yes/no menu with caption queryString. The actual wording for the two choices will be as provided in the trueChoice and falseChoice parameters. Answer true if the response is the true-choice, false if it's the false-choice. This is a modal question -- the user must respond one way or the other." ^PopUpMenu confirm: queryString trueChoice: trueChoice falseChoice: falseChoice! ----- Method: MVCUIManager>>dialogStringFromQuery:withTitle: (in category 'private') ----- dialogStringFromQuery: queryString withTitle: titleString "In Morphic, it is common to display a simple dialog that has a title bar. In MVC, simple dialogs are simple. If the UIManager requests a dialog with title, add the title as a simply decorated line at the top of the dialog text." ^String streamContents: [ :strm | strm nextPutAll: '- '; nextPutAll: titleString; nextPutAll: ' -'; nextPut: Character cr; nextPutAll: queryString ] ! ----- Method: MVCUIManager>>displayProgress:at:from:to:during: (in category 'ui requests') ----- displayProgress: titleString at: aPoint from: minVal to: maxVal during: workBlock "Display titleString as a caption over a progress bar while workBlock is evaluated." | delta savedArea captionText textFrame barFrame outerFrame result range lastW | barFrame := aPoint - (75@10) corner: aPoint + (75@10). captionText := DisplayText text: titleString asText allBold. captionText foregroundColor: Color black backgroundColor: Color white. textFrame := captionText boundingBox insetBy: -4. textFrame := textFrame align: textFrame bottomCenter with: barFrame topCenter + (0@2). outerFrame := barFrame merge: textFrame. delta := outerFrame amountToTranslateWithin: Display boundingBox. barFrame := barFrame translateBy: delta. textFrame := textFrame translateBy: delta. outerFrame := outerFrame translateBy: delta. savedArea := Form fromDisplay: outerFrame. Display fillBlack: barFrame; fillWhite: (barFrame insetBy: 2). Display fillBlack: textFrame; fillWhite: (textFrame insetBy: 2). captionText displayOn: Display at: textFrame topLeft + (4@4). range := maxVal = minVal ifTrue: [1] ifFalse: [maxVal - minVal]. "Avoid div by 0" lastW := 0. [result := workBlock value: "Supply the bar-update block for evaluation in the work block" [:barVal | | w | w := ((barFrame width-4) asFloat * ((barVal-minVal) asFloat / range min: 1.0)) asInteger. w ~= lastW ifTrue: [ Display fillGray: (barFrame topLeft + (2@2) extent: w@16). lastW := w]]] ensure: [savedArea displayOn: Display at: outerFrame topLeft]. ^result! ----- Method: MVCUIManager>>edit:label:accept: (in category 'ui requests') ----- edit: aText label: labelString accept: anAction "Open an editor on the given string/text" Workspace new acceptContents: aText; acceptAction: anAction; openLabel: labelString ! ----- Method: MVCUIManager>>inform: (in category 'ui requests') ----- inform: aString "Display a message for the user to read and then dismiss" ^PopUpMenu inform: aString! ----- Method: MVCUIManager>>informUser:during: (in category 'ui requests') ----- informUser: aString during: aBlock "Display a message above (or below if insufficient room) the cursor during execution of the given block. UIManager default informUser: 'Just a sec!!' during: [(Delay forSeconds: 1) wait]. " (SelectionMenu labels: '') displayAt: Sensor cursorPoint withCaption: aString during: aBlock! ----- Method: MVCUIManager>>informUserDuring: (in category 'ui requests') ----- informUserDuring: aBlock "Display a message above (or below if insufficient room) the cursor during execution of the given block. UIManager default informUserDuring:[:bar| #(one two three) do:[:info| bar value: info. (Delay forSeconds: 1) wait]]" aBlock value:[:string| Transcript cr; show: string].! ----- Method: MVCUIManager>>multiLineRequest:centerAt:initialAnswer:answerHeight: (in category 'ui requests') ----- multiLineRequest: queryString centerAt: aPoint initialAnswer: defaultAnswer answerHeight: answerHeight "Create a multi-line instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer nil if the user cancels. An empty string returned means that the ussr cleared the editing area and then hit 'accept'. Because multiple lines are invited, we ask that the user use the ENTER key, or (in morphic anyway) hit the 'accept' button, to submit; that way, the return key can be typed to move to the next line." ^FillInTheBlank multiLineRequest: queryString centerAt: aPoint initialAnswer: defaultAnswer answerHeight: answerHeight! ----- Method: MVCUIManager>>newDisplayDepthNoRestore: (in category 'display') ----- newDisplayDepthNoRestore: pixelSize "Change depths. Check if there is enough space!! , di" | area need | pixelSize = Display depth ifTrue: [^ self "no change"]. pixelSize abs < Display depth ifFalse: ["Make sure there is enough space" area := Display boundingBox area. "pixels" ScheduledControllers scheduledWindowControllers do: [:aController | "This should be refined..." aController view cacheBitsAsTwoTone ifFalse: [area := area + aController view windowBox area]]. need := (area * (pixelSize abs - Display depth) // 8) "new bytes needed" + Smalltalk lowSpaceThreshold. (Smalltalk garbageCollectMost <= need and: [Smalltalk garbageCollect <= need]) ifTrue: [self error: 'Insufficient free space']]. Display setExtent: Display extent depth: pixelSize. ScheduledControllers updateGray. DisplayScreen startUp! ----- Method: MVCUIManager>>request:initialAnswer: (in category 'ui requests') ----- request: queryString initialAnswer: defaultAnswer "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer the empty string if the user cancels." ^FillInTheBlank request: queryString initialAnswer: defaultAnswer ! ----- Method: MVCUIManager>>request:initialAnswer:centerAt: (in category 'ui requests') ----- request: queryString initialAnswer: defaultAnswer centerAt: aPoint "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer the empty string if the user cancels." ^ FillInTheBlank request: queryString initialAnswer: defaultAnswer centerAt: aPoint ! ----- Method: MVCUIManager>>requestPassword: (in category 'ui requests') ----- requestPassword: queryString "Create an instance of me whose question is queryString. Invoke it centered at the cursor, and answer the string the user accepts. Answer the empty string if the user cancels." ^FillInTheBlank requestPassword: queryString! ----- Method: MVCUIManager>>restoreDisplay (in category 'display') ----- restoreDisplay "Restore the bits on Display" Project current ifNotNil:[:p| p invalidate; restore].! ----- Method: MVCUIManager>>restoreDisplayAfter: (in category 'display') ----- restoreDisplayAfter: aBlock "Evaluate the block, wait for a mouse click, and then restore the screen." aBlock value. Sensor waitButton. self restoreDisplay!

1 0

Squeak 4.6: ShoutCore-mt.51.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of ShoutCore to project Squeak 4.6: http://source.squeak.org/squeak46/ShoutCore-mt.51.mcz ==================== Summary ==================== Name: ShoutCore-mt.51 Author: mt Time: 6 May 2015, 9:37:51.463 am UUID: 58d9bae4-356c-8745-940b-f394a6dde152 Ancestors: ShoutCore-mt.50 Some ShoutCore dependencies untangled. ==================== Snapshot ==================== SystemOrganization addCategory: #'ShoutCore-Monticello'! SystemOrganization addCategory: #'ShoutCore-Parsing'! SystemOrganization addCategory: #'ShoutCore-Styling'! (PackageInfo named: 'ShoutCore') postscript: 'SHTextStylerST80 syntaxHighlightingAsYouType: Preferences syntaxHighlightingAsYouType. SHTextStylerST80 syntaxHighlightingAsYouTypeLeftArrowAssignment: Preferences syntaxHighlightingAsYouTypeLeftArrowAssignment. SHTextStylerST80 syntaxHighlightingAsYouTypeAnsiAssignment: Preferences syntaxHighlightingAsYouTypeAnsiAssignment.'! ----- Method: TextAttribute>>shoutShouldPreserve (in category '*ShoutCore') ----- shoutShouldPreserve ^false! ----- Method: TextAction>>shoutShouldPreserve (in category '*ShoutCore') ----- shoutShouldPreserve ^true! ----- Method: Model>>hasBindingThatBeginsWith: (in category '*ShoutCore') ----- hasBindingThatBeginsWith: aString ^ false! ----- Method: MCSnapshotBrowser>>hasBindingThatBeginsWith: (in category '*ShoutCore') ----- hasBindingThatBeginsWith: aString ^false! Object subclass: #SHMCClassDefinition instanceVariableNames: 'classDefinition items meta' classVariableNames: '' poolDictionaries: '' category: 'ShoutCore-Monticello'! ----- Method: SHMCClassDefinition class>>classDefinition:items:meta: (in category 'as yet unclassified') ----- classDefinition: aMCClassDefinition items: anObject meta: aBoolean ^self new classDefinition: aMCClassDefinition; items: anObject; meta: aBoolean; yourself! ----- Method: SHMCClassDefinition>>allInstVarNames (in category 'act like a class') ----- allInstVarNames | superclassOrDef answer classOrDef instVars| answer := meta ifTrue:[classDefinition classInstVarNames asArray] ifFalse:[ classDefinition instVarNames asArray]. classOrDef := classDefinition. [superclassOrDef := (classOrDef isKindOf: MCClassDefinition) ifTrue:[ |s| s := classOrDef superclassName. items detect: [:ea | ea isClassDefinition and: [ea className = s]] ifNone: [Smalltalk at: s asSymbol ifAbsent:[nil]]] ifFalse:[ | sc | sc := classOrDef superclass. sc ifNotNil:[ items detect: [:ea | ea isClassDefinition and: [ea className = sc name asString]] ifNone: [sc] ]]. superclassOrDef isNil ] whileFalse:[ instVars := (superclassOrDef isKindOf: MCClassDefinition) ifTrue:[ meta ifTrue:[superclassOrDef classInstVarNames] ifFalse:[superclassOrDef instVarNames]] ifFalse:["real" meta ifTrue:[superclassOrDef theNonMetaClass class instVarNames] ifFalse:[superclassOrDef theNonMetaClass instVarNames]]. answer := answer, instVars. classOrDef := superclassOrDef]. ^answer! ----- Method: SHMCClassDefinition>>allowUnderscoreAssignments (in category 'act like a class') ----- allowUnderscoreAssignments ^nil! ----- Method: SHMCClassDefinition>>bindingOf: (in category 'act like environment') ----- bindingOf: aSymbol | binding | (binding := Smalltalk bindingOf: aSymbol) ifNotNil: [^binding]. items do:[:each | (each isClassDefinition and: [each className = aSymbol]) ifTrue:[^aSymbol -> each]]. ^nil! ----- Method: SHMCClassDefinition>>classDefinition: (in category 'accessing') ----- classDefinition: aMCClassDefinition classDefinition := aMCClassDefinition! ----- Method: SHMCClassDefinition>>classPool (in category 'act like a class') ----- classPool | d | d := Dictionary new. classDefinition classVarNames do:[:each | d at: each put: nil]. ^d! ----- Method: SHMCClassDefinition>>environment (in category 'act like a class') ----- environment ^self! ----- Method: SHMCClassDefinition>>hasBindingThatBeginsWith: (in category 'act like environment') ----- hasBindingThatBeginsWith: aString (Smalltalk globals hasBindingThatBeginsWith: aString) ifTrue: [^true]. items do:[:each | (each isClassDefinition and: [each className beginsWith: aString]) ifTrue:[^true]]. ^false! ----- Method: SHMCClassDefinition>>items: (in category 'accessing') ----- items: anObject items := anObject! ----- Method: SHMCClassDefinition>>meta: (in category 'accessing') ----- meta: aBoolean meta := aBoolean! ----- Method: SHMCClassDefinition>>sharedPools (in category 'act like a class') ----- sharedPools | d | d := Set new. classDefinition poolDictionaries do:[:each | d add: [Smalltalk at: each asSymbol ifAbsent:[nil]] ]. ^d! ----- Method: SHMCClassDefinition>>shoutParserClass (in category 'act like a class') ----- shoutParserClass "Answer the parser class" ^SHParserST80! ----- Method: SHMCClassDefinition>>theNonMetaClass (in category 'act like a class') ----- theNonMetaClass ^self copy meta: false; yourself! ----- Method: SHMCClassDefinition>>withAllSuperclasses (in category 'act like a class') ----- withAllSuperclasses | result | result := OrderedCollection new. self withAllSuperclassesDo: [ :each | result addFirst: each ]. ^result! ----- Method: SHMCClassDefinition>>withAllSuperclassesDo: (in category 'act like a class') ----- withAllSuperclassesDo: aBlock | superclassOrDef classOrDef | aBlock value: self. classOrDef := classDefinition. [ superclassOrDef := (classOrDef isKindOf: MCClassDefinition) ifTrue: [ | superclassName | superclassName := classOrDef superclassName. items detect: [ :each | each isClassDefinition and: [ each className = superclassName ] ] ifNone: [ Smalltalk classNamed: superclassName ] ] ifFalse: [ classOrDef superclass ifNotNil: [ :superclass | | superclassName | superclassName := superclass name asString. items detect: [ :each | each isClassDefinition and: [ each className = superclassName ] ] ifNone: [ superclass ] ] ]. superclassOrDef isNil ] whileFalse: [ aBlock value: superclassOrDef. classOrDef := superclassOrDef ]! Object subclass: #SHParserST80 instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges environment allowUnderscoreAssignments allowUnderscoreSelectors parseAMethod' classVariableNames: '' poolDictionaries: '' category: 'ShoutCore-Parsing'! !SHParserST80 commentStamp: 'tween 8/16/2004 15:44' prior: 0! I am a Smalltalk method / expression parser. Rather than creating an Abstract Syntax Tree, I create a sequence of SHRanges (in my 'ranges' instance variable), which represent the tokens within the String I am parsing. I am used by a SHTextStylerST80 to parse method source strings. I am able to parse incomplete / incorrect methods, and so can be used to parse methods that are being edited. My 'source' instance variable should be set to the string to be parsed. My 'classOrMetaClass' instance var must be set to the class or metaClass for the method source so that I can correctly resolve identifiers within the source. If this is nil , I parse the source as an expression (i.e. a doIt expression). My 'workspace' instance variable can be set to a Workspace, so that I can resolve workspace variables. My 'environment' instance variable is the global namespace (this is initialized to Smalltalk, but can be set to a different environment). Example 1. ranges := SHParserST80 new classOrMetaClass: Object; source: 'testMethod ^self'; parse; ranges ! ----- Method: SHParserST80 class>>new (in category 'instance creation') ----- new ^super new initialize; yourself! ----- Method: SHParserST80>>classOrMetaClass: (in category 'accessing') ----- classOrMetaClass: aClass classOrMetaClass := aClass! ----- Method: SHParserST80>>currentChar (in category 'scan') ----- currentChar ^source at: sourcePosition ifAbsent: nil! ----- Method: SHParserST80>>enterBlock (in category 'parse support') ----- enterBlock blockDepth := blockDepth + 1. bracketDepth := bracketDepth + 1! ----- Method: SHParserST80>>environment: (in category 'accessing') ----- environment: anObject environment := anObject! ----- Method: SHParserST80>>error (in category 'error handling') ----- error self rangeType: #excessCode start: (ranges isEmpty ifTrue: [1] ifFalse: [ranges last end + 1]) end: source size. errorBlock value! ----- Method: SHParserST80>>failUnless: (in category 'error handling') ----- failUnless: aBoolean aBoolean ifFalse:[self error] ! ----- Method: SHParserST80>>failWhen: (in category 'error handling') ----- failWhen: aBoolean aBoolean ifTrue:[self error]! ----- Method: SHParserST80>>initialize (in category 'accessing') ----- initialize environment := Smalltalk globals.! ----- Method: SHParserST80>>initializeInstanceVariables (in category 'parse support') ----- initializeInstanceVariables instanceVariables := classOrMetaClass ifNil: [ #() ] ifNotNil: [ classOrMetaClass allInstVarNames asArray ]! ----- Method: SHParserST80>>isAnsiAssignment (in category 'token testing') ----- isAnsiAssignment ^currentToken = ':='! ----- Method: SHParserST80>>isAssignment (in category 'token testing') ----- isAssignment self isAnsiAssignment ifTrue: [ ^true ]. ^allowUnderscoreAssignments and: [ currentToken = '_' ]! ----- Method: SHParserST80>>isBigDigit:base: (in category 'character testing') ----- isBigDigit: aCharacter base: anInteger "Answer true if aCharacter is a digit or a capital letter appropriate for base anInteger" | digitValue | digitValue := aCharacter digitValue. ^digitValue >= 0 and:[digitValue < anInteger]! ----- Method: SHParserST80>>isBinary (in category 'token testing') ----- isBinary currentToken ifNil: [ ^false ]. self isName ifTrue: [ ^false ]. self isKeyword ifTrue: [ ^false ]. 1 to: currentToken size do: [ :i | (self isSelectorCharacter: (currentToken at: i)) ifFalse: [ ^false ] ]. ^true! ----- Method: SHParserST80>>isBlockArgName: (in category 'identifier testing') ----- isBlockArgName: aString "Answer true if aString is the name of a block argument, false otherwise" | temp arg | blockDepth to: 1 by: -1 do: [:level | arg := (arguments at: level ifAbsent: [#()]) includes: aString. arg ifTrue: [^true]. temp := (temporaries at: level ifAbsent: [#()]) includes: aString. temp ifTrue: [^false]]. ^false! ----- Method: SHParserST80>>isBlockTempName: (in category 'identifier testing') ----- isBlockTempName: aString "Answer true if aString is the name of a block temporary. false otherwise" | temp arg | blockDepth to: 1 by: -1 do: [:level | arg := (arguments at: level ifAbsent: [#()]) includes: aString. arg ifTrue: [^false]. temp := (temporaries at: level ifAbsent: [#()]) includes: aString. temp ifTrue: [^true]]. ^false! ----- Method: SHParserST80>>isIncompleteBlockArgName: (in category 'identifier testing') ----- isIncompleteBlockArgName: aString "Answer true if aString is the start of the name of a block argument, false otherwise" | arg | blockDepth to: 1 by: -1 do: [:level | arg := (arguments at: level ifAbsent: [#()]) anySatisfy: [:each | each beginsWith: aString]. arg ifTrue: [^true]]. ^false! ----- Method: SHParserST80>>isIncompleteBlockTempName: (in category 'identifier testing') ----- isIncompleteBlockTempName: aString "Answer true if aString is the start of the name of a block temporary. false otherwise" | temp | blockDepth to: 1 by: -1 do: [:level | temp := (temporaries at: level ifAbsent: [#()]) anySatisfy: [:each | each beginsWith: aString]. temp ifTrue: [^true]]. ^false! ----- Method: SHParserST80>>isIncompleteMethodArgName: (in category 'identifier testing') ----- isIncompleteMethodArgName: aString "Answer true if aString is the start of the name of a method argument, false otherwise. Does not check whether aString is also a blockArgName" ^(arguments at: 0 ifAbsent: [#()]) anySatisfy: [:each | each beginsWith: aString]! ----- Method: SHParserST80>>isIncompleteMethodTempName: (in category 'identifier testing') ----- isIncompleteMethodTempName: aString "Answer true if aString is the start of then name of a method temporary, false otherwise." ^(temporaries at: 0 ifAbsent: [#()]) anySatisfy: [:each | each beginsWith: aString]! ----- Method: SHParserST80>>isKeyword (in category 'token testing') ----- isKeyword "This method assumes that currentTokenFirst is a non-letter character when currentToken is nil." currentTokenFirst isLetter ifTrue: [ ^currentToken last == $: ]. ^allowUnderscoreSelectors and: [ currentTokenFirst == $_ and: [ currentToken notNil and: [ currentToken size > 1 and: [ currentToken last == $: ] ] ] ]! ----- Method: SHParserST80>>isMethodArgName: (in category 'identifier testing') ----- isMethodArgName: aString "Answer true if aString is the name of a method argument, false otherwise. Does not check whether aString is also a blockArgName" ^(arguments at: 0 ifAbsent: [#()]) includes: aString! ----- Method: SHParserST80>>isMethodTempName: (in category 'identifier testing') ----- isMethodTempName: aString "Answer true if aString is the name of a method temporary, false otherwise. Does not check whether aString is also a block temporary or argument" ((arguments at: 0 ifAbsent: [#()]) includes: aString) ifTrue: [^false]. ^(temporaries at: 0 ifAbsent: [#()]) includes: aString! ----- Method: SHParserST80>>isName (in category 'token testing') ----- isName "This method assumes that currentTokenFirst is a non-letter character when currentToken is nil." ^(currentTokenFirst isLetter or: [ allowUnderscoreSelectors and: [ currentTokenFirst == $_ and: [ currentToken notNil and: [ currentToken size > 1 ] ] ] ]) and: [ currentToken last isAlphaNumeric or: [ allowUnderscoreSelectors and: [ currentToken last == $_ ] ] ] ! ----- Method: SHParserST80>>isSelectorCharacter: (in category 'character testing') ----- isSelectorCharacter: aCharacter | asciiValue | ('"#$'':().;[]{}^_' includes: aCharacter) ifTrue: [ ^false ]. aCharacter isSeparator ifTrue:[ ^false ]. aCharacter isAlphaNumeric ifTrue: [ ^false ]. (asciiValue := aCharacter asciiValue) = 30 ifTrue: [ ^false "the doIt char" ]. ^asciiValue ~= 0 "Any other char, but 0 is ok as a binary selector char." ! ----- Method: SHParserST80>>isTokenExternalFunctionCallingConvention (in category 'token testing') ----- isTokenExternalFunctionCallingConvention | descriptorClass | descriptorClass := Smalltalk at: #ExternalFunction ifAbsent: [nil]. descriptorClass == nil ifTrue: [^false]. ^(descriptorClass callingConventionFor: currentToken) notNil! ----- Method: SHParserST80>>leaveBlock (in category 'parse support') ----- leaveBlock arguments removeKey: blockDepth ifAbsent: []. temporaries removeKey: blockDepth ifAbsent: []. blockDepth := blockDepth - 1. bracketDepth := bracketDepth - 1! ----- Method: SHParserST80>>nextChar (in category 'scan') ----- nextChar ^source at: (sourcePosition := sourcePosition + 1) ifAbsent: $ ! ----- Method: SHParserST80>>parse (in category 'parse') ----- parse "Parse the receiver's text as a Smalltalk method" self parse: (parseAMethod ifNil: [ classOrMetaClass notNil ]). errorBlock := nil! ----- Method: SHParserST80>>parse: (in category 'parse') ----- parse: isAMethod "Parse the receiver's text. If isAMethod is true then treat text as a method, if false as an expression with no message pattern" self initializeInstanceVariables. allowUnderscoreAssignments := Scanner allowUnderscoreAsAssignment. allowUnderscoreSelectors := Scanner prefAllowUnderscoreSelectors. sourcePosition := 1. arguments := Dictionary new. temporaries := Dictionary new. blockDepth := bracketDepth := 0. ranges ifNil: [ ranges := OrderedCollection new: 40 "Covers over 80% of all methods." ] ifNotNil: [ ranges reset ]. errorBlock := [^false]. self scanNext. isAMethod ifTrue: [ self parseMessagePattern; parsePragmaSequence ]. self parseMethodTemporaries. isAMethod ifTrue: [ self parsePragmaSequence ]. self parseStatementList. currentToken ifNotNil: [ self error ]. ^true! ----- Method: SHParserST80>>parseAMethod: (in category 'accessing') ----- parseAMethod: aBoolean parseAMethod := aBoolean! ----- Method: SHParserST80>>parseArray (in category 'parse') ----- parseArray [currentTokenFirst == $)] whileFalse: [self parseLiteralArrayElement]. self scanPast: #arrayEnd! ----- Method: SHParserST80>>parseBinary (in category 'parse') ----- parseBinary | binary type | self parseUnary. [self isBinary] whileTrue: [ binary := currentToken. type := #binary. (binary isEmpty or:[(Symbol lookup: binary) notNil]) ifFalse:[ type := (Symbol thatStartsCaseSensitive: binary skipping: nil) ifNil: [#undefinedBinary] ifNotNil:[#incompleteBinary]]. self scanPast: type. self parseTerm. self parseUnary] ! ----- Method: SHParserST80>>parseBinaryMessagePattern (in category 'parse') ----- parseBinaryMessagePattern self scanPast: #patternBinary. self failUnless: self isName. self scanPast: #patternArg. ! ----- Method: SHParserST80>>parseBlock (in category 'parse') ----- parseBlock self enterBlock. self scanPast: #blockStart level: bracketDepth. currentTokenFirst == $: ifTrue: [self parseBlockArguments]. currentTokenFirst == $| ifTrue: [self parseBlockTemporaries]. self parseStatementList. self failUnless: currentTokenFirst == $]. self scanPast: #blockEnd level: bracketDepth. self leaveBlock! ----- Method: SHParserST80>>parseBlockArguments (in category 'parse') ----- parseBlockArguments [currentTokenFirst == $:] whileTrue: [ self scanPast: #blockArgColon. self failUnless: self isName. self scanPast: #blockPatternArg]. currentTokenFirst == $| ifTrue: [^self scanPast: #blockArgsBar]! ----- Method: SHParserST80>>parseBlockTemporaries (in category 'parse') ----- parseBlockTemporaries currentTokenFirst == $| ifTrue: [ self scanPast: #blockTempBar. [self isName] whileTrue: [self scanPast: #blockPatternTempVar]. self failUnless: currentToken = '|'. self scanPast: #blockTempBar]! ----- Method: SHParserST80>>parseBraceArray (in category 'parse') ----- parseBraceArray self parseStatementListForBraceArray. self failUnless: currentTokenFirst == $}. self scanPast: #rightBrace! ----- Method: SHParserST80>>parseByteArray (in category 'parse') ----- parseByteArray [currentTokenFirst == $]] whileFalse: [ currentTokenFirst isDigit ifTrue: [ "do not parse the number, can be time consuming" self scanPast: #number] ifFalse: [ self failWhen: currentTokenFirst == $. . self error]]. self scanPast: #byteArrayEnd! ----- Method: SHParserST80>>parseCascade (in category 'parse') ----- parseCascade self parseKeyword. [currentTokenFirst == $;] whileTrue: [ self scanPast: #cascadeSeparator. self parseKeyword]! ----- Method: SHParserST80>>parseCharSymbol (in category 'parse') ----- parseCharSymbol | s e | s := sourcePosition - 1. e := sourcePosition. self nextChar. self scanPast: #symbol start: s end: e! ----- Method: SHParserST80>>parseExpression (in category 'parse') ----- parseExpression | assignType | self isName ifTrue: [ self scanPast: (self resolve: currentToken). self isAssignment ifTrue: [ assignType := self isAnsiAssignment ifTrue: [#ansiAssignment] ifFalse: [#assignment]. self scanPast: assignType. self parseExpression] ifFalse: [self parseCascade]] ifFalse: [ self parseTerm. self parseCascade]! ----- Method: SHParserST80>>parseExternalCall (in category 'parse') ----- parseExternalCall [self scanNext. ((Smalltalk at: #ExternalFunction) callingConventionModifierFor: currentToken) notNil] whileTrue. self failUnless: currentToken notNil. self scanPast: #externalCallType. currentToken = '*' ifTrue: [self scanPast: #externalCallTypePointerIndicator]. currentTokenFirst isDigit ifTrue: [self scanPast: #integer] ifFalse: [ self failUnless: currentTokenFirst == $'. self parseString]. self failUnless: currentTokenFirst == $(. self scanPast: #leftParenthesis. [currentTokenFirst ~= $)] whileTrue: [ self failUnless: currentToken notNil. self scanPast: #externalCallType. currentToken = '*' ifTrue: [self scanPast: #externalCallTypePointerIndicator]]. self scanPast: #rightParenthesis. currentToken = 'module:' ifTrue: [ self scanPast: #module. self parseStringOrSymbol ]. currentToken = 'error:' ifTrue: [ self scanPast: #primitive. "there's no rangeType for error" self isName ifTrue: [ self scanPast: #patternTempVar ] ifFalse: [ self parseStringOrSymbol ] ]. self failUnless: currentToken = '>'. self scanPast: #primitiveOrExternalCallEnd! ----- Method: SHParserST80>>parseKeyword (in category 'parse') ----- parseKeyword | keyword rangeIndices | self parseBinary. keyword := ''. rangeIndices := #(). [ [self isKeyword] whileTrue: [ keyword := keyword, currentToken. self rangeType: #keyword. "remember where this keyword token is in ranges" rangeIndices := rangeIndices copyWith: ranges size. self scanNext. self parseTerm. self parseBinary ] ] ensure: [ | type | "do this in an ensure so that it happens even if the errorBlock evaluates before getting here" "patch up the keyword tokens, so that incomplete and undefined ones look different" (keyword isEmpty or:[(Symbol lookup: keyword) notNil]) ifFalse:[ type := (Symbol thatStartsCaseSensitive: keyword skipping: nil) ifNil: [#undefinedKeyword] ifNotNil:[#incompleteKeyword]. rangeIndices do: [:i | (ranges at: i) type: type]]]! ----- Method: SHParserST80>>parseKeywordMessagePattern (in category 'parse') ----- parseKeywordMessagePattern [self isKeyword] whileTrue: [ self scanPast: #patternKeyword. self failUnless: self isName. self scanPast: #patternArg] ! ----- Method: SHParserST80>>parseLiteral: (in category 'parse') ----- parseLiteral: inArray currentTokenFirst == $$ ifTrue: [ | pos | self failWhen: self currentChar isNil. self rangeType: #'$'. pos := currentTokenSourcePosition + 1. self nextChar. ^self scanPast: #character start: pos end: pos]. currentTokenFirst isDigit ifTrue: [ "do not parse the number, can be time consuming" ^self scanPast: #number]. currentToken = '-' ifTrue: [ | c | c := self currentChar. (inArray and: [c isNil or: [ c isDigit not ]]) ifTrue: [ "single - can be a symbol in an Array" ^self scanPast: #symbol]. self scanPast: #-. self failWhen: currentToken isNil. "token isNil ifTrue: [self error: 'Unexpected End Of Input']." "do not parse the number, can be time consuming" ^self scanPast: #number]. currentTokenFirst == $' ifTrue: [^self parseString]. currentTokenFirst == $# ifTrue: [^self parseSymbol]. (inArray and: [currentToken notNil]) ifTrue: [^self scanPast: #symbol]. self failWhen: currentTokenFirst == $. . self error ": 'argument missing'"! ----- Method: SHParserST80>>parseLiteralArrayElement (in category 'parse') ----- parseLiteralArrayElement currentTokenFirst isLetter ifTrue: [ #true = currentToken ifTrue: [ ^self scanPast: #true ]. #false = currentToken ifTrue: [ ^self scanPast: #false ]. #nil = currentToken ifTrue: [ ^self scanPast: #nil ]. ^self scanPast: #symbol ]. currentTokenFirst == $( ifTrue: [ self scanPast: #arrayStart. ^self parseArray ]. ^self parseLiteral: true! ----- Method: SHParserST80>>parseMessagePattern (in category 'parse') ----- parseMessagePattern self isName ifTrue: [self parseUnaryMessagePattern] ifFalse: [ self isBinary ifTrue:[self parseBinaryMessagePattern] ifFalse:[ self failUnless: self isKeyword. self parseKeywordMessagePattern]]! ----- Method: SHParserST80>>parseMethodTemporaries (in category 'parse') ----- parseMethodTemporaries currentTokenFirst == $| ifTrue: [ self scanPast: #methodTempBar. [self isName] whileTrue: [self scanPast: #patternTempVar]. self failUnless: currentToken = '|'. self scanPast: #methodTempBar]! ----- Method: SHParserST80>>parsePragmaBinary (in category 'parse') ----- parsePragmaBinary self scanPast: #pragmaBinary. self isName ifTrue:[self scanPast: (self resolvePragmaArgument: currentToken)] ifFalse:[ self parseLiteral: false]. self failUnless: currentToken = '>'. self scanPast: #primitiveOrExternalCallEnd! ----- Method: SHParserST80>>parsePragmaKeyword (in category 'parse') ----- parsePragmaKeyword [self isKeyword] whileTrue:[ self scanPast: #pragmaKeyword. self isName ifTrue:[self scanPast: (self resolvePragmaArgument: currentToken)] ifFalse:[ self parseLiteral: false]]. self failUnless: currentToken = '>'. self scanPast: #primitiveOrExternalCallEnd! ----- Method: SHParserST80>>parsePragmaSequence (in category 'parse') ----- parsePragmaSequence [currentToken = '<' ] whileTrue:[ self scanPast: #primitiveOrExternalCallStart. currentToken = 'primitive:' ifTrue: [ self rangeType: #primitive. self parsePrimitive] ifFalse:[ self isTokenExternalFunctionCallingConvention ifTrue: [ self rangeType: #externalFunctionCallingConvention. self parseExternalCall] ifFalse:[ self isName ifTrue:[ self scanPast: #pragmaUnary. self failUnless: currentToken = '>'. self scanPast: #primitiveOrExternalCallEnd] ifFalse:[ self isKeyword ifTrue:[ self parsePragmaKeyword] ifFalse:[ self isBinary ifTrue:[self parsePragmaBinary] ifFalse:[ self error ": 'Invalid External Function Calling convention'" ]]]]]]! ----- Method: SHParserST80>>parsePrimitive (in category 'parse') ----- parsePrimitive self scanNext. currentTokenFirst isDigit ifTrue: [ self scanPast: #integer ] ifFalse: [ self parseStringOrSymbol. currentToken = 'module:' ifTrue: [ self scanPast: #module. self parseStringOrSymbol ] ]. currentToken = 'error:' ifTrue: [ self scanPast: #primitive. "there's no rangeType for error" self isName ifTrue: [ self scanPast: #patternTempVar ] ifFalse: [ self parseStringOrSymbol ] ]. self failUnless: currentToken = '>'. self scanPast: #primitiveOrExternalCallEnd! ----- Method: SHParserST80>>parseStatement (in category 'parse') ----- parseStatement currentTokenFirst == $^ ifTrue: [self scanPast: #return]. self parseExpression! ----- Method: SHParserST80>>parseStatementList (in category 'parse') ----- parseStatementList [[currentTokenFirst == $.] whileTrue: [self scanPast: #statementSeparator]. (currentToken notNil and: [currentTokenFirst ~~ $]]) ifTrue: [self parseStatement]. currentTokenFirst == $.] whileTrue: [self scanPast: #statementSeparator]! ----- Method: SHParserST80>>parseStatementListForBraceArray (in category 'parse') ----- parseStatementListForBraceArray "same as parseStatementList, but does not allow empty statements e.g {...$a...}. A single terminating . IS allowed e.g. {$a.} " [currentTokenFirst ~~ $} ifTrue: [self parseStatement]. currentTokenFirst == $.] whileTrue: [self scanPast: #statementSeparator]! ----- Method: SHParserST80>>parseString (in category 'parse') ----- parseString | first c last | first := sourcePosition. [(c := self currentChar) ifNil: [ self rangeType: #unfinishedString start: first - 1 end: source size. self error ": 'unfinished string'"]. c ~~ $' or: [ self peekChar == $' ifTrue: [ sourcePosition := sourcePosition + 1. true] ifFalse: [false]] ] whileTrue: [sourcePosition := sourcePosition + 1]. last := sourcePosition. self nextChar. self scanPast: #string start: first - 1 end: last! ----- Method: SHParserST80>>parseStringOrSymbol (in category 'parse') ----- parseStringOrSymbol currentTokenFirst == $' ifTrue: [ ^self parseString ]. currentTokenFirst == $# ifTrue: [ ^self parseSymbol ]. self error! ----- Method: SHParserST80>>parseSymbol (in category 'parse') ----- parseSymbol | c | currentToken = '#' ifTrue: [ "if token is just the #, then scan whitespace and comments and then process the next character. Squeak allows space between the # and the start of the symbol e.g. # (), # a, # 'sym' " self rangeType: #symbol. self scanWhitespace]. c := self currentChar. self failWhen: (c isNil or: [c isSeparator]). c == $( ifTrue: [ self nextChar. self scanPast: #arrayStart start: currentTokenSourcePosition end: currentTokenSourcePosition + 1. ^self parseArray]. c == $' ifTrue: [^self parseSymbolString]. c == $[ ifTrue: [ self nextChar. self scanPast: #byteArrayStart start: currentTokenSourcePosition end: currentTokenSourcePosition + 1. ^self parseByteArray]. ((self isSelectorCharacter: c) or: [c == $-]) ifTrue: [^self parseSymbolSelector]. (c isLetter or: [ c == $: or: [ allowUnderscoreSelectors and: [ c == $_ ] ] ]) ifTrue: [^self parseSymbolIdentifier]. ^self parseCharSymbol! ----- Method: SHParserST80>>parseSymbolIdentifier (in category 'parse') ----- parseSymbolIdentifier | c start end | c := self currentChar. self failUnless: ( c isLetter or: [ c == $: or: [ allowUnderscoreSelectors and: [ c == $_ ] ] ]). start := sourcePosition. [ (c := self nextChar) isAlphaNumeric or: [ c == $: or: [ allowUnderscoreSelectors and: [ c == $_ ] ] ] ] whileTrue. end := sourcePosition - 1. c := source copyFrom: start - 1 to: end. self scanPast: #symbol start: start - 1 end: end. ^c! ----- Method: SHParserST80>>parseSymbolSelector (in category 'parse') ----- parseSymbolSelector | start end | start := sourcePosition - 1. end := sourcePosition. [self isSelectorCharacter: self nextChar] whileTrue: [end := sourcePosition]. self scanPast: #symbol start: start end: end! ----- Method: SHParserST80>>parseSymbolString (in category 'parse') ----- parseSymbolString | first c last | first := sourcePosition. self nextChar. [(c := self currentChar) ifNil: [ self rangeType: #unfinishedString start: first end: source size. self error ": 'unfinished string'"]. c ~~ $' or: [ self peekChar == $' ifTrue: [sourcePosition := sourcePosition + 1.true] ifFalse: [false]] ] whileTrue: [sourcePosition := sourcePosition + 1]. last := sourcePosition. self nextChar. self scanPast: #stringSymbol start: first - 1 end: last! ----- Method: SHParserST80>>parseTerm (in category 'parse') ----- parseTerm self failWhen: currentToken isNil. currentTokenFirst == $( ifTrue: [ bracketDepth := bracketDepth + 1. self scanPast: #leftParenthesis level: bracketDepth. self parseExpression. self failUnless: currentTokenFirst == $). self scanPast: #rightParenthesis level: bracketDepth. ^bracketDepth := bracketDepth - 1]. currentTokenFirst == $[ ifTrue: [^self parseBlock]. currentTokenFirst == ${ ifTrue: [ self scanPast: #leftBrace. ^self parseBraceArray]. self isName ifTrue: [^self scanPast: (self resolve: currentToken)]. self parseLiteral: false! ----- Method: SHParserST80>>parseUnary (in category 'parse') ----- parseUnary | unary type | [self isName] whileTrue: [ unary := currentToken. type := #unary. (unary isEmpty or:[(Symbol lookup: unary) notNil]) ifFalse:[ type := (Symbol thatStartsCaseSensitive: unary skipping: nil) ifNil: [#undefinedUnary] ifNotNil:[#incompleteUnary]]. self scanPast: type] ! ----- Method: SHParserST80>>parseUnaryMessagePattern (in category 'parse') ----- parseUnaryMessagePattern self scanPast: #patternUnary ! ----- Method: SHParserST80>>parsingBlockArguments (in category 'token testing') ----- parsingBlockArguments ^ranges notEmpty and: [ranges last type == #blockPatternArg]! ----- Method: SHParserST80>>peekChar (in category 'scan') ----- peekChar ^source at: sourcePosition + 1 ifAbsent: $ ! ----- Method: SHParserST80>>pushArgument: (in category 'parse support') ----- pushArgument: aString (arguments at: blockDepth ifAbsentPut: [OrderedCollection new: 10]) add: aString! ----- Method: SHParserST80>>pushTemporary: (in category 'parse support') ----- pushTemporary: aString (temporaries at: blockDepth ifAbsentPut: [ OrderedCollection new ]) add: aString! ----- Method: SHParserST80>>rangeType: (in category 'recording ranges') ----- rangeType: aSymbol ^self rangeType: aSymbol start: currentTokenSourcePosition end: currentTokenSourcePosition + currentToken size - 1! ----- Method: SHParserST80>>rangeType:start:end: (in category 'recording ranges') ----- rangeType: aSymbol start: s end: e ^ranges add: (SHRange start: s end: e type: aSymbol)! ----- Method: SHParserST80>>ranges (in category 'accessing') ----- ranges ^ranges! ----- Method: SHParserST80>>rangesIn:classOrMetaClass:workspace:environment: (in category 'parse') ----- rangesIn: sourceString classOrMetaClass: aBehaviour workspace: aWorkspace environment: anEnvironmentOrNil anEnvironmentOrNil ifNotNil: [environment := anEnvironmentOrNil]. self workspace: aWorkspace; classOrMetaClass: aBehaviour; source: sourceString. self parse. ^ranges! ----- Method: SHParserST80>>resolve: (in category 'identifier testing') ----- resolve: aString aString = #self ifTrue: [ ^#self ]. aString = #true ifTrue: [ ^#true ]. aString = #false ifTrue: [ ^#false ]. aString = #nil ifTrue: [ ^#nil ]. aString = #super ifTrue: [ ^#super ]. aString = #thisContext ifTrue: [ ^#thisContext ]. (self isBlockTempName: aString) ifTrue: [^#blockTempVar]. (self isBlockArgName: aString) ifTrue: [^#blockArg]. (self isMethodTempName: aString) ifTrue: [^#tempVar]. (self isMethodArgName: aString) ifTrue: [^#methodArg]. (instanceVariables includes: aString) ifTrue: [^#instVar]. workspace ifNotNil: [(workspace hasBindingOf: aString) ifTrue: [^#workspaceVar]]. (Symbol lookup: aString) ifNotNil: [:sym | classOrMetaClass ifNotNil: [ classOrMetaClass theNonMetaClass withAllSuperclassesDo: [:c | (c classPool bindingOf: sym) ifNotNil: [^#classVar]. c sharedPools do: [:p | (p bindingOf: sym) ifNotNil: [^#poolConstant]]. (c environment bindingOf: sym) ifNotNil: [^#globalVar]]] ifNil: [(environment bindingOf: sym) ifNotNil: [^#globalVar]]]. ^self resolvePartial: aString! ----- Method: SHParserST80>>resolvePartial: (in category 'identifier testing') ----- resolvePartial: aString "check if any identifier begins with aString" (#('self' 'super' 'true' 'false' 'nil' 'thisContext') anySatisfy: [:each | each beginsWith: aString]) ifTrue: [^#incompleteIdentifier]. (self isIncompleteBlockTempName: aString) ifTrue: [^#incompleteIdentifier]. (self isIncompleteBlockArgName: aString) ifTrue: [^#incompleteIdentifier]. (self isIncompleteMethodTempName: aString) ifTrue: [^#incompleteIdentifier]. (self isIncompleteMethodArgName: aString) ifTrue: [^#incompleteIdentifier]. (instanceVariables anySatisfy: [:each | each beginsWith: aString]) ifTrue: [^#incompleteIdentifier]. workspace ifNotNil: [(workspace hasBindingThatBeginsWith: aString) ifTrue: [^#incompleteIdentifier]]. classOrMetaClass ifNotNil: [ classOrMetaClass theNonMetaClass withAllSuperclassesDo: [:c | (c classPool hasBindingThatBeginsWith: aString) ifTrue: [^#incompleteIdentifier]. c sharedPools do: [:p | (p hasBindingThatBeginsWith: aString) ifTrue: [^#incompleteIdentifier]]. (c environment hasBindingThatBeginsWith: aString) ifTrue: [^#incompleteIdentifier]]] ifNil: [(environment hasBindingThatBeginsWith: aString) ifTrue: [^#incompleteIdentifier]]. ^#undefinedIdentifier! ----- Method: SHParserST80>>resolvePartialPragmaArgument: (in category 'identifier testing') ----- resolvePartialPragmaArgument: aString "check if any valid pragma argument begins with aString" (#('true' 'false' 'nil') anySatisfy: [:each | each beginsWith: aString]) ifTrue: [^#incompleteIdentifier]. "should really check that a matching binding is for a Class?" classOrMetaClass ifNotNil: [ classOrMetaClass theNonMetaClass withAllSuperclassesDo: [:c | (c environment hasBindingThatBeginsWith: aString) ifTrue: [^#incompleteIdentifier]]] ifNil: [(environment hasBindingThatBeginsWith: aString) ifTrue: [^#incompleteIdentifier]]. ^#undefinedIdentifier! ----- Method: SHParserST80>>resolvePragmaArgument: (in category 'identifier testing') ----- resolvePragmaArgument: aString (#('true' 'false' 'nil') includes: aString) ifTrue: [^aString asSymbol]. "should really check that global is a class?" (Symbol lookup: aString) ifNotNil: [:sym | classOrMetaClass ifNotNil: [ classOrMetaClass theNonMetaClass withAllSuperclassesDo: [:c | (c environment bindingOf: sym) ifNotNil: [^#globalVar]]] ifNil: [(environment bindingOf: sym) ifNotNil: [^#globalVar]]]. ^self resolvePartialPragmaArgument: aString! ----- Method: SHParserST80>>scanBinary (in category 'scan') ----- scanBinary | c d | c := self currentChar. currentTokenSourcePosition := sourcePosition. currentToken := c asString. d := self nextChar. ((self isSelectorCharacter: c) or: [c == $:]) ifFalse: [^currentToken]. (c == $: and: [d == $=]) ifTrue: " := assignment" [currentToken := currentToken , d asString. self nextChar. ^currentToken]. ((c == $|) and: [self parsingBlockArguments]) ifTrue: [^currentToken]. [self isSelectorCharacter: d] whileTrue: [currentToken := currentToken , d asString. d := self nextChar]. ^currentToken! ----- Method: SHParserST80>>scanComment (in category 'scan') ----- scanComment | start | start := sourcePosition. (sourcePosition := source indexOf: $" startingAt: start + 1) = 0 ifTrue: [ sourcePosition := source size + 1. self rangeType: #unfinishedComment start: start end: source size. ^self error ]. start < sourcePosition ifTrue: [ self rangeType: #comment start: start end: sourcePosition ]. self nextChar; scanWhitespace! ----- Method: SHParserST80>>scanIdentifier (in category 'scan') ----- scanIdentifier | c start | start := sourcePosition. [ (c := self nextChar) isAlphaNumeric or: [ allowUnderscoreSelectors and: [ c == $_ ] ] ] whileTrue. (c == $: and: [ (self isSelectorCharacter: self peekChar) not ]) ifTrue: [ self nextChar ]. currentToken := source copyFrom: start to: sourcePosition - 1. currentTokenSourcePosition := start! ----- Method: SHParserST80>>scanNext (in category 'scan') ----- scanNext self scanWhitespace. currentTokenFirst := self currentChar ifNil: [ " end of input " currentTokenFirst := $ . currentTokenSourcePosition := nil. currentToken := nil. ^nil ]. currentTokenFirst isDigit ifTrue: [ ^self scanNumber ]. (currentTokenFirst isLetter or: [ allowUnderscoreSelectors and: [ currentTokenFirst == $_ ] ]) ifTrue: [ ^self scanIdentifier ]. ^self scanBinary! ----- Method: SHParserST80>>scanNumber (in category 'scan') ----- scanNumber | start c nc base | start := sourcePosition. self skipDigits. c := self currentChar. c == $r ifTrue: [ base := Integer readFrom: (ReadStream on: (source copyFrom: start to: sourcePosition - 1)). self peekChar == $- ifTrue:[self nextChar]. self skipBigDigits: base. c := self currentChar. c == $. ifTrue: [ (self isBigDigit: self nextChar base: base) ifFalse: [sourcePosition := sourcePosition - 1] ifTrue: [self skipBigDigits: base]]. c := self currentChar. ('deq'includes: c) ifTrue: [ ((nc := self nextChar) isDigit or: [nc == $- and: [ self peekChar isDigit ]]) ifFalse: [sourcePosition := sourcePosition - 1] ifTrue: [self skipDigits]]. c == $s ifTrue: [ (nc := self nextChar) isDigit ifTrue: [ self skipDigits ] ifFalse: [ nc isLetter ifTrue: [ sourcePosition := sourcePosition - 1 ] ] ]. currentToken := source copyFrom: start to: sourcePosition - 1. ^currentTokenSourcePosition := start]. c == $s ifTrue: [ (nc := self nextChar) isDigit ifFalse: [nc isLetter ifTrue: [sourcePosition := sourcePosition - 1]] ifTrue: [self skipDigits.]. currentToken := source copyFrom: start to: sourcePosition - 1. ^currentTokenSourcePosition := start]. c == $. ifTrue: [ self nextChar isDigit ifFalse: [ sourcePosition := sourcePosition - 1. currentToken := source copyFrom: start to: sourcePosition - 1. ^currentTokenSourcePosition := start] ifTrue: [self skipDigits]]. c := self currentChar. ('deq' includes: c) ifTrue: [ ((nc := self nextChar) isDigit or: [nc == $- and:[ self peekChar isDigit ]]) ifFalse: [sourcePosition := sourcePosition - 1] ifTrue: [self skipDigits]]. c == $s ifTrue: [ (nc := self nextChar) isDigit ifFalse: [nc isLetter ifTrue: [sourcePosition := sourcePosition - 1]] ifTrue: [self skipDigits]]. currentToken := source copyFrom: start to: sourcePosition - 1. ^currentTokenSourcePosition := start! ----- Method: SHParserST80>>scanPast: (in category 'scan') ----- scanPast: rangeType "record rangeType for current token . record argument and temp declarations. scan and answer the next token" rangeType == #blockPatternArg ifTrue: [self pushArgument: currentToken]. rangeType == #blockPatternTempVar ifTrue: [self pushTemporary: currentToken]. rangeType == #patternArg ifTrue: [self pushArgument: currentToken]. rangeType == #patternTempVar ifTrue: [self pushTemporary: currentToken]. ^self rangeType: rangeType; scanNext! ----- Method: SHParserST80>>scanPast:level: (in category 'scan') ----- scanPast: rangeType level: level "first level adds no suffix to the rangeType. Suffix from 1 to 7 added in cycles , ((level-2) mod(7) + 1)" | cycle typePlusCycle | cycle := level <= 1 ifTrue: [0] ifFalse:[ ((level - 2) \\ 7) + 1]. typePlusCycle := cycle = 0 ifTrue:[rangeType] ifFalse:[(rangeType, cycle asString) asSymbol]. ^self scanPast: typePlusCycle ! ----- Method: SHParserST80>>scanPast:start:end: (in category 'scan') ----- scanPast: rangeType start: startInteger end: endInteger "record rangeType for current token from startInteger to endInteger, and scanNext token" ^self rangeType: rangeType start: startInteger end: endInteger; scanNext ! ----- Method: SHParserST80>>scanWhitespace (in category 'scan') ----- scanWhitespace (self currentChar ifNil: [ ^self ]) isSeparator ifTrue: [ sourcePosition := source indexOfAnyOf: CharacterSet nonSeparators startingAt: sourcePosition + 1. sourcePosition = 0 ifTrue: [ "Not found" sourcePosition := source size + 1 ] ]. self currentChar == $" ifTrue: [ self scanComment ]! ----- Method: SHParserST80>>skipBigDigits: (in category 'scan') ----- skipBigDigits: baseInteger [self isBigDigit: self nextChar base: baseInteger] whileTrue: [] ! ----- Method: SHParserST80>>skipDigits (in category 'scan') ----- skipDigits [ self nextChar isDigit ] whileTrue! ----- Method: SHParserST80>>source (in category 'accessing') ----- source ^source! ----- Method: SHParserST80>>source: (in category 'accessing') ----- source: aString source := aString ! ----- Method: SHParserST80>>workspace: (in category 'accessing') ----- workspace: aWorkspace workspace := aWorkspace! Object subclass: #SHRange instanceVariableNames: 'start end type' classVariableNames: '' poolDictionaries: '' category: 'ShoutCore-Parsing'! !SHRange commentStamp: 'tween 8/16/2004 15:16' prior: 0! I associate a type with a range of characters in a String I have these instance variables... start - the one based index of the first character of the range within the String. end - the one based index of the last character of the range within the String. type - a Symbol describing the type of the range A sequence of instances of me are created by an instance of SHParserST80 which can then used by an instance of SHTextStyler to style Text. ! ----- Method: SHRange class>>start:end:type: (in category 'instance creation') ----- start: s end: e type: aSymbol ^self new start: s end: e type: aSymbol; yourself! ----- Method: SHRange>>end (in category 'accessing') ----- end ^end! ----- Method: SHRange>>end: (in category 'accessing') ----- end: anInteger end := anInteger! ----- Method: SHRange>>length (in category 'accessing') ----- length ^end - start + 1! ----- Method: SHRange>>printOn: (in category 'accessing') ----- printOn: stream super printOn: stream. stream nextPut: $(; print: type; nextPutAll: ', '; print: start; nextPutAll: ', '; print: end; nextPut: $)! ----- Method: SHRange>>start (in category 'accessing') ----- start ^start! ----- Method: SHRange>>start: (in category 'accessing') ----- start: anInteger start := anInteger! ----- Method: SHRange>>start:end:type: (in category 'accessing') ----- start: startInteger end: endInteger type: typeSymbol start := startInteger. end := endInteger. type := typeSymbol! ----- Method: SHRange>>type (in category 'accessing') ----- type ^type! ----- Method: SHRange>>type: (in category 'accessing') ----- type: aSymbol type := aSymbol! Object subclass: #SHTextStyler instanceVariableNames: 'sem backgroundProcess text monitor view stylingEnabled' classVariableNames: '' poolDictionaries: '' category: 'ShoutCore-Styling'! !SHTextStyler commentStamp: 'tween 8/27/2004 10:54' prior: 0! I am an Abstract class. Subclasses of me can create formatted, coloured, and styled copies of Text that is given to them. They may perform their styling asynchronously, in a background process which I create and manage. My public interface is... view: aViewOrMorph - set the view that will receive notifications when styling has completed. format: aText - modifies aText's string style: aText - modifies the TextAttributes of aText, but does not change the string, then sends #stylerStyled: to the view. styleInBackgroundProcess: aText - performs style: in a background process, then sends #stylerStylednBackground: to the view. styledTextFor: aText - answers a formatted and styled copy of aText unstyledTextFrom: aText - answers a copy of aText with all TextAttributes removed Subclasses of me should re-implement... privateFormat: aText - answer a formatted version of aText; the String may be changed privateStyle: aText - modify the TextAttributes of aText; but do not change the String ! ----- Method: SHTextStyler>>evaluateWithoutStyling: (in category 'styling') ----- evaluateWithoutStyling: aBlock | t | t := stylingEnabled. stylingEnabled := false. ^ aBlock ensure: [stylingEnabled := t]! ----- Method: SHTextStyler>>format: (in category 'formatting') ----- format: aText "Answer a copy of <aText> which has been reformatted, or <aText> if no formatting is to be applied" self terminateBackgroundStylingProcess. ^self privateFormat: aText! ----- Method: SHTextStyler>>initialize (in category 'styling') ----- initialize stylingEnabled := true ! ----- Method: SHTextStyler>>monitor (in category 'private') ----- monitor ^monitor ifNil: [monitor := Monitor new]! ----- Method: SHTextStyler>>privateFormat: (in category 'private') ----- privateFormat: aText self shouldBeImplemented! ----- Method: SHTextStyler>>privateStyle: (in category 'private') ----- privateStyle: aText self shouldBeImplemented! ----- Method: SHTextStyler>>style: (in category 'styling') ----- style: aText self terminateBackgroundStylingProcess. stylingEnabled ifTrue:[ text := aText copy. self privateStyle: text. view ifNotNil:[view stylerStyled: text] ]! ----- Method: SHTextStyler>>styleInBackgroundProcess: (in category 'styling') ----- styleInBackgroundProcess: aText self terminateBackgroundStylingProcess. stylingEnabled ifTrue:[ text := aText copy. self monitor critical: [ sem := Semaphore new. [sem notNil ifTrue: [ sem wait. view ifNotNil:[view stylerStyledInBackground: text]] ] forkAt: Processor activePriority. backgroundProcess := [self privateStyle: text. sem signal] forkAt: Processor userBackgroundPriority] ] ! ----- Method: SHTextStyler>>styledTextFor: (in category 'styling') ----- styledTextFor: aText "Answer a copy of aText that is both formatted and styled" | formattedText | formattedText := self privateFormat: aText. self privateStyle: formattedText. ^formattedText! ----- Method: SHTextStyler>>terminateBackgroundStylingProcess (in category 'private') ----- terminateBackgroundStylingProcess self monitor critical: [ backgroundProcess ifNotNil: [ backgroundProcess terminate. backgroundProcess := nil]. sem ifNotNil:[ sem terminateProcess. sem := nil]. ] ! ----- Method: SHTextStyler>>unstyledTextFrom: (in category 'styling') ----- unstyledTextFrom: aText ^Text fromString: aText string! ----- Method: SHTextStyler>>veryDeepInner: (in category 'copying') ----- veryDeepInner: aDeepCopier super veryDeepInner: aDeepCopier. sem := backgroundProcess := monitor := nil. text := text veryDeepCopyWith: aDeepCopier. view := view veryDeepCopyWith: aDeepCopier! ----- Method: SHTextStyler>>view: (in category 'accessing') ----- view: aViewOrMorph view := aViewOrMorph! SHTextStyler subclass: #SHTextStylerST80 instanceVariableNames: 'classOrMetaClass workspace font parser formatAssignments environment sourceMap processedSourceMap pixelHeight attributesByPixelHeight parseAMethod' classVariableNames: 'SubduedSyntaxHighlights SyntaxHighlightingAsYouType SyntaxHighlightingAsYouTypeAnsiAssignment SyntaxHighlightingAsYouTypeLeftArrowAssignment' poolDictionaries: '' category: 'ShoutCore-Styling'! SHTextStylerST80 class instanceVariableNames: 'styleTable textAttributesByPixelHeight'! !SHTextStylerST80 commentStamp: 'tween 8/27/2004 10:55' prior: 0! I style Smalltalk methods and expressions. My 'styleTable' class instance var holds an array ofArrays which control how each token is styled/coloured. See my defaultStyleTable class method for its structure. My styleTable can be changed by either modifying the defaultStyleTable class method and then executing SHTextStylerST80 initialize ; or by giving me a new styleTable through my #styleTable: class method. My 'textAttributesByPixelSize' class instance var contains a dictionary of dictionaries. The key is a pixelSize and the value a Dictionary from token type Symbol to TextAttribute array. It is created/maintained automatically. I also install these 3 preferences when my class initialize method is executed.... #syntaxHighlightingAsYouType - controls whether methods are styled in browsers #syntaxHighlightingAsYouTypeAnsiAssignment - controls whether assignments are formatted to be := #syntaxHighlightingAsYouTypeLeftArrowAssignment - controls whether assignments are formatted to be _ I reimplement #unstyledTextFrom: so that TextActions are preserved in the unstyled text ! SHTextStylerST80 class instanceVariableNames: 'styleTable textAttributesByPixelHeight'! ----- Method: SHTextStylerST80 class>>ansiAssignmentPreferenceChanged (in category 'preferences') ----- ansiAssignmentPreferenceChanged "the user has changed the syntaxHighlightingAsYouTypeAnsiAssignment setting. If they have turned it on then force syntaxHighlightingAsYouTypeLeftArrowAssignment to be turned off" self syntaxHighlightingAsYouTypeAnsiAssignment ifTrue: [self syntaxHighlightingAsYouTypeLeftArrowAssignment: false]! ----- Method: SHTextStylerST80 class>>attributeArrayForColor:emphasis:font: (in category 'style table') ----- attributeArrayForColor: aColorOrNil emphasis: anEmphasisSymbolOrArrayorNil font: aTextStyleOrFontOrNil "Answer a new Array containing any non nil TextAttributes specified" | answer emphArray | answer := Array new. aColorOrNil ifNotNil: [answer := answer, {TextColor color: aColorOrNil}]. anEmphasisSymbolOrArrayorNil ifNotNil: [ emphArray := anEmphasisSymbolOrArrayorNil isSymbol ifTrue: [{anEmphasisSymbolOrArrayorNil}] ifFalse: [anEmphasisSymbolOrArrayorNil]. emphArray do: [:each | each ~= #normal ifTrue:[ answer := answer, {TextEmphasis perform: each}]]]. aTextStyleOrFontOrNil ifNotNil: [ answer := answer, {TextFontReference toFont: aTextStyleOrFontOrNil}]. ^answer! ----- Method: SHTextStylerST80 class>>attributesByPixelHeight: (in category 'style table') ----- attributesByPixelHeight: aNumber ^self textAttributesByPixelHeight at: aNumber ifAbsent: [ | result | result := self initialTextAttributesForPixelHeight: aNumber. " thread safety first " textAttributesByPixelHeight := textAttributesByPixelHeight copy at: aNumber put: result; yourself. result ]! ----- Method: SHTextStylerST80 class>>attributesFor:pixelHeight: (in category 'style table') ----- attributesFor: aSymbol pixelHeight: aNumber ^(self textAttributesByPixelHeight at: aNumber ifAbsentPut:[self initialTextAttributesForPixelHeight: aNumber]) at: aSymbol ifAbsent:[nil]! ----- Method: SHTextStylerST80 class>>chooseDefaultStyleTable (in category 'style table') ----- chooseDefaultStyleTable "Choose the default style table" ^self subduedSyntaxHighlights ifTrue:[self subduedStyleTable] ifFalse:[self defaultStyleTable]! ----- Method: SHTextStylerST80 class>>defaultStyleTable (in category 'style table') ----- defaultStyleTable "color can be a valid argument to Color class>>colorFrom: , or nil to use the editor text color. Multiple emphases can be specified using an array e.g. #(bold italic). If emphasis is not specified, #normal will be used. if pixel height is not specified , then the editor font size will be used. " ^#( "(symbol color [emphasisSymbolOrArray [textStyleName [pixelHeight]]])" (default black ) (invalid red ) (excessCode red ) (comment (green muchDarker) italic) (unfinishedComment (red muchDarker) italic) (#'$' (red muchDarker) ) (character (red muchDarker) ) (integer (red muchDarker) ) (number (red muchDarker) ) (#- (red muchDarker) ) (symbol (blue muchDarker) bold) (stringSymbol (blue muchDarker) bold) (literalArray (blue muchDarker) bold) (string (magenta muchDarker) normal) (unfinishedString red normal ) (assignment nil bold ) (ansiAssignment nil bold) (literal nil italic) (keyword (blue muchDarker) ) (binary (blue muchDarker) ) (unary (blue muchDarker) ) (incompleteKeyword (gray muchDarker) underlined) (incompleteBinary (gray muchDarker) underlined) (incompleteUnary (gray muchDarker) underlined) (undefinedKeyword red ) (undefinedBinary red ) (undefinedUnary red ) (patternKeyword nil bold) (patternBinary nil bold) (patternUnary nil bold) (#self (red muchDarker) bold) (#super (red muchDarker) bold) (#true (red muchDarker) bold) (#false (red muchDarker) bold) (#nil (red muchDarker) bold) (#thisContext (red muchDarker) bold) (#return (red muchDarker) bold) (patternArg (blue muchDarker) italic) (methodArg (blue muchDarker) italic) (blockPatternArg (blue muchDarker) italic) (blockArg (blue muchDarker) italic) (argument (blue muchDarker) italic) (blockArgColon black ) (leftParenthesis black ) (rightParenthesis black ) (leftParenthesis1 (green muchDarker) ) (rightParenthesis1 (green muchDarker) ) (leftParenthesis2 (magenta muchDarker) ) (rightParenthesis2 (magenta muchDarker) ) (leftParenthesis3 (red muchDarker) ) (rightParenthesis3 (red muchDarker) ) (leftParenthesis4 (green darker) ) (rightParenthesis4 (green darker) ) (leftParenthesis5 (orange darker) ) (rightParenthesis5 (orange darker) ) (leftParenthesis6 (magenta darker) ) (rightParenthesis6 (magenta darker) ) (leftParenthesis7 blue ) (rightParenthesis7 blue ) (blockStart black ) (blockEnd black ) (blockStart1 (green muchDarker) ) (blockEnd1 (green muchDarker) ) (blockStart2 (magenta muchDarker) ) (blockEnd2 (magenta muchDarker) ) (blockStart3 (red muchDarker) ) (blockEnd3 (red muchDarker) ) (blockStart4 (green darker) ) (blockEnd4 (green darker) ) (blockStart5 (orange darker) ) (blockEnd5 (orange darker) ) (blockStart6 (magenta darker) ) (blockEnd6 (magenta darker) ) (blockStart7 blue ) (blockEnd7 blue ) (arrayStart black ) (arrayEnd black ) (arrayStart1 black ) (arrayEnd1 black ) (byteArrayStart black ) (byteArrayEnd black ) (byteArrayStart1 black ) (byteArrayEnd1 black ) (leftBrace black ) (rightBrace black ) (cascadeSeparator black ) (statementSeparator black ) (externalCallType black ) (externalCallTypePointerIndicator black ) (primitiveOrExternalCallStart black bold ) (primitiveOrExternalCallEnd black bold ) (methodTempBar gray ) (blockTempBar gray ) (blockArgsBar gray ) (primitive (green muchDarker) bold) (pragmaKeyword (green muchDarker) bold) (pragmaUnary (green muchDarker) bold) (pragmaBinary (green muchDarker) bold) (externalFunctionCallingConvention (green muchDarker) bold) (module (green muchDarker) bold) (blockTempVar gray italic) (blockPatternTempVar gray italic) (instVar black bold) (workspaceVar black bold) (undefinedIdentifier red bold) (incompleteIdentifier (gray darker) (italic underlined)) (tempVar (gray darker) italic) (patternTempVar (gray darker) italic) (poolConstant (gray darker) italic) (classVar (gray darker) bold) (globalVar black bold) ) ! ----- Method: SHTextStylerST80 class>>initialTextAttributesForPixelHeight: (in category 'style table') ----- initialTextAttributesForPixelHeight: aNumber | d | d := IdentityDictionary new. self styleTable do: [:each | | textStyle element emphasis font pixelHeight attrArray color textStyleName | element := each first. color := each at: 2 ifAbsent:[nil]. color:=color ifNotNil: [Color colorFrom: color]. emphasis := each at: 3 ifAbsent:[nil]. textStyleName := each at: 4 ifAbsent: [nil]. pixelHeight := each at: 5 ifAbsent: [aNumber]. textStyleName ifNil:[pixelHeight := nil]. textStyle := TextStyle named: textStyleName. font := textStyle ifNotNil:[pixelHeight ifNotNil:[textStyle fontOfSize: pixelHeight]]. attrArray := self attributeArrayForColor: color emphasis: emphasis font: font. attrArray notEmpty ifTrue:[ d at: element put: attrArray]]. ^d ! ----- Method: SHTextStylerST80 class>>initialize (in category 'class initialization') ----- initialize "Clear styleTable and textAttributesByPixelSize cache so that they will reinitialize. SHTextStylerST80 initialize " styleTable := nil. textAttributesByPixelHeight := nil. ! ----- Method: SHTextStylerST80 class>>leftArrowAssignmentPreferenceChanged (in category 'preferences') ----- leftArrowAssignmentPreferenceChanged "the user has changed the syntaxHighlightingAsYouTypeLeftArrowAssignment setting. If they have turned it on then force syntaxHighlightingAsYouTypeAnsiAssignment to be turned off" self syntaxHighlightingAsYouTypeLeftArrowAssignment ifTrue: [self syntaxHighlightingAsYouTypeAnsiAssignment: false]! ----- Method: SHTextStylerST80 class>>styleTable (in category 'style table') ----- styleTable ^styleTable ifNil: [ styleTable := self chooseDefaultStyleTable ]! ----- Method: SHTextStylerST80 class>>styleTable: (in category 'style table') ----- styleTable: anArray "Set the receiver's styleTable to anArray. Clear textAttributesByPixelSize cache so that it will reinitialize. " styleTable := anArray. textAttributesByPixelHeight := nil! ----- Method: SHTextStylerST80 class>>subduedStyleTable (in category 'style table') ----- subduedStyleTable "color can be a valid argument to Color class>>colorFrom: , or nil to use the editor text color. Multiple emphases can be specified using an array e.g. #(bold italic). If emphasis is not specified, #normal will be used. if pixel height is not specified , then the editor font size will be used. " ^#( "(symbol color [emphasisSymbolOrArray [textStyleName [pixelHeight]]])" (default black ) (invalid red ) (excessCode red ) (comment (cyan muchDarker) ) (unfinishedComment (red muchDarker) italic) (#'$' (red muchDarker) ) (character (red muchDarker) ) (integer (red muchDarker) ) (number (red muchDarker) ) (#- (red muchDarker) ) (symbol (blue muchDarker) ) (stringSymbol (blue muchDarker) ) (literalArray (blue muchDarker) ) (string (magenta muchDarker) normal ) (unfinishedString red normal ) (assignment nil bold ) (ansiAssignment nil bold) (literal nil italic) (keyword (blue muchDarker) ) (binary (blue muchDarker) ) (unary (blue muchDarker) ) (incompleteKeyword (gray muchDarker) underlined) (incompleteBinary (gray muchDarker) underlined) (incompleteUnary (gray muchDarker) underlined) (undefinedKeyword red ) (undefinedBinary red ) (undefinedUnary red ) (patternKeyword nil bold) (patternBinary nil bold) (patternUnary nil bold) (#self (red muchDarker) ) (#super (red muchDarker) ) (#true (red muchDarker) ) (#false (red muchDarker) ) (#nil (red muchDarker) ) (#thisContext (red muchDarker) ) (#return (red muchDarker) ) (patternArg (blue muchDarker) ) (methodArg (blue muchDarker) ) (blockPatternArg (blue muchDarker) ) (blockArg (blue muchDarker) ) (argument (blue muchDarker) ) (blockArgColon black ) (leftParenthesis black ) (rightParenthesis black ) (leftParenthesis1 (green muchDarker) ) (rightParenthesis1 (green muchDarker) ) (leftParenthesis2 (magenta muchDarker) ) (rightParenthesis2 (magenta muchDarker) ) (leftParenthesis3 (red muchDarker) ) (rightParenthesis3 (red muchDarker) ) (leftParenthesis4 (green darker) ) (rightParenthesis4 (green darker) ) (leftParenthesis5 (orange darker) ) (rightParenthesis5 (orange darker) ) (leftParenthesis6 (magenta darker) ) (rightParenthesis6 (magenta darker) ) (leftParenthesis7 blue ) (rightParenthesis7 blue ) (blockStart black ) (blockEnd black ) (blockStart1 (green muchDarker) ) (blockEnd1 (green muchDarker) ) (blockStart2 (magenta muchDarker) ) (blockEnd2 (magenta muchDarker) ) (blockStart3 (red muchDarker) ) (blockEnd3 (red muchDarker) ) (blockStart4 (green darker) ) (blockEnd4 (green darker) ) (blockStart5 (orange darker) ) (blockEnd5 (orange darker) ) (blockStart6 (magenta darker) ) (blockEnd6 (magenta darker) ) (blockStart7 blue ) (blockEnd7 blue ) (arrayStart black ) (arrayEnd black ) (arrayStart1 black ) (arrayEnd1 black ) (byteArrayStart black ) (byteArrayEnd black ) (byteArrayStart1 black ) (byteArrayEnd1 black ) (leftBrace black ) (rightBrace black ) (cascadeSeparator black ) (statementSeparator black ) (externalCallType black ) (externalCallTypePointerIndicator black ) (primitiveOrExternalCallStart black ) (primitiveOrExternalCallEnd black ) (methodTempBar gray ) (blockTempBar gray ) (blockArgsBar gray ) (primitive (green muchDarker) bold) (pragmaKeyword (green muchDarker) bold) (pragmaUnary (green muchDarker) bold) (pragmaBinary (green muchDarker) bold) (externalFunctionCallingConvention (green muchDarker) bold) (module (green muchDarker) bold) (blockTempVar gray ) (blockPatternTempVar gray ) (instVar black ) (workspaceVar black ) (undefinedIdentifier red ) (incompleteIdentifier (gray darker) (italic underlined)) (tempVar (gray darker) ) (patternTempVar (gray darker) ) (poolConstant (gray muchDarker) ) (classVar (gray muchDarker) ) (globalVar black ) )! ----- Method: SHTextStylerST80 class>>subduedSyntaxHighlights (in category 'preferences') ----- subduedSyntaxHighlights <preference: 'Subdued Syntax Highlighting' category: 'browsing' description: 'When enabled, use a more subdued syntax highlighting approach that is not as aggressive in the face newbies. Intended to introduce people gracefully to the shiny colorful world of Squeak syntax' type: #Boolean> ^SubduedSyntaxHighlights ifNil:[true]! ----- Method: SHTextStylerST80 class>>subduedSyntaxHighlights: (in category 'preferences') ----- subduedSyntaxHighlights: aBool "Change the subdued syntax highlighting preference" SubduedSyntaxHighlights := aBool. "Force reload" styleTable := nil. textAttributesByPixelHeight := nil.! ----- Method: SHTextStylerST80 class>>syntaxHighlightingAsYouType (in category 'preferences') ----- syntaxHighlightingAsYouType <preference: 'syntaxHighlightingAsYouType' category: 'browsing' description: 'Enable, or disable, Shout - Syntax Highlighting As You Type. When enabled, code in Browsers and Workspaces is styled to reveal its syntactic structure. When the code is changed (by typing some characters, for example), the styling is changed so that it remains in sync with the modified code.' type: #Boolean> ^SyntaxHighlightingAsYouType ifNil: [true]! ----- Method: SHTextStylerST80 class>>syntaxHighlightingAsYouType: (in category 'preferences') ----- syntaxHighlightingAsYouType: aBoolean SyntaxHighlightingAsYouType := aBoolean.! ----- Method: SHTextStylerST80 class>>syntaxHighlightingAsYouTypeAnsiAssignment (in category 'preferences') ----- syntaxHighlightingAsYouTypeAnsiAssignment <preference: 'syntaxHighlightingAsYouTypeAnsiAssignment' category: 'browsing' description: 'If true, and syntaxHighlightingAsYouType is enabled, all left arrow assignments ( _ ) will be converted to the ANSI format ( := ) when a method is selected in a Browser. Whilst editing a method, this setting has no effect - both the left arrow and the ansi format may be used.' type: #Boolean> ^SyntaxHighlightingAsYouTypeLeftArrowAssignment ifNil: [true]! ----- Method: SHTextStylerST80 class>>syntaxHighlightingAsYouTypeAnsiAssignment: (in category 'preferences') ----- syntaxHighlightingAsYouTypeAnsiAssignment: aBoolean SyntaxHighlightingAsYouTypeAnsiAssignment := aBoolean.! ----- Method: SHTextStylerST80 class>>syntaxHighlightingAsYouTypeLeftArrowAssignment (in category 'preferences') ----- syntaxHighlightingAsYouTypeLeftArrowAssignment <preference: 'syntaxHighlightingAsYouTypeLeftArrowAssignment' category: 'browsing' description: 'If true, and syntaxHighlightingAsYouType is enabled, all ANSI format assignments ( := ) will be converted to left arrows ( _ ) when a method is selected in a Browser. Whilst editing a method, this setting has no effect - both the left arrow and the ansi format may be used.' type: #Boolean> ^SyntaxHighlightingAsYouTypeLeftArrowAssignment ifNil: [true]! ----- Method: SHTextStylerST80 class>>syntaxHighlightingAsYouTypeLeftArrowAssignment: (in category 'preferences') ----- syntaxHighlightingAsYouTypeLeftArrowAssignment: aBoolean SyntaxHighlightingAsYouTypeLeftArrowAssignment := aBoolean.! ----- Method: SHTextStylerST80 class>>textAttributesByPixelHeight (in category 'style table') ----- textAttributesByPixelHeight ^ textAttributesByPixelHeight ifNil: [ textAttributesByPixelHeight := Dictionary new ]! ----- Method: SHTextStylerST80>>attributesFor: (in category 'private') ----- attributesFor: aSymbol ^(attributesByPixelHeight ifNil: [ attributesByPixelHeight := self class attributesByPixelHeight: self pixelHeight ]) at: aSymbol ifAbsent: nil! ----- Method: SHTextStylerST80>>classOrMetaClass: (in category 'accessing') ----- classOrMetaClass: aBehavior classOrMetaClass := aBehavior! ----- Method: SHTextStylerST80>>convertAssignmentsToAnsi: (in category 'private') ----- convertAssignmentsToAnsi: aText "If the Preference is to show ansiAssignments then answer a copy of <aText> where each left arrow assignment is replaced with a ':=' ansi assignment. A parser is used so that each left arrow is only replaced if it occurs within an assigment statement" ^self replaceStringForRangesWithType: #assignment with: ':=' in: aText! ----- Method: SHTextStylerST80>>convertAssignmentsToLeftArrow: (in category 'private') ----- convertAssignmentsToLeftArrow: aText "If the Preference is to show leftArrowAssignments then answer a copy of <aText> where each ansi assignment (:=) is replaced with a left arrow. A parser is used so that each ':=' is only replaced if it actually occurs within an assigment statement" ^self replaceStringForRangesWithType: #ansiAssignment with: '_' in: aText! ----- Method: SHTextStylerST80>>environment: (in category 'accessing') ----- environment: anObject environment := anObject! ----- Method: SHTextStylerST80>>font: (in category 'accessing') ----- font: aFont font := aFont! ----- Method: SHTextStylerST80>>formatAssignments: (in category 'accessing') ----- formatAssignments: aBoolean "determines whether assignments are reformatted according to the Preferences, or left as they are" formatAssignments := aBoolean! ----- Method: SHTextStylerST80>>initialize (in category 'initialize-release') ----- initialize super initialize. formatAssignments := true! ----- Method: SHTextStylerST80>>parseAMethod: (in category 'accessing') ----- parseAMethod: aBoolean parseAMethod := aBoolean! ----- Method: SHTextStylerST80>>parseableSourceCodeTemplate (in category 'private') ----- parseableSourceCodeTemplate ^'messageSelectorAndArgumentNames "comment stating purpose of message" | temporary variable names | statements'! ----- Method: SHTextStylerST80>>pixelHeight (in category 'private') ----- pixelHeight "In Morphic the receiver will have been given a code font, in MVC the font will be nil. So when the font is nil, answer the pixelHeight of the MVC Browsers' code font, i.e. TextStyle defaultFont pixelHeight" ^pixelHeight ifNil:[pixelHeight := (font ifNil:[TextStyle defaultFont]) pixelSize]! ----- Method: SHTextStylerST80>>privateFormat: (in category 'private') ----- privateFormat: aText "Perform any formatting of aText necessary and answer either aText, or a formatted copy of aText" aText asString = Object sourceCodeTemplate ifTrue:[ "the original source code template does not parse, replace it with one that does" ^self parseableSourceCodeTemplate asText]. formatAssignments ifTrue:[ self class syntaxHighlightingAsYouTypeAnsiAssignment ifTrue:[^self convertAssignmentsToAnsi: aText]. self class syntaxHighlightingAsYouTypeLeftArrowAssignment ifTrue:[^self convertAssignmentsToLeftArrow: aText]]. ^aText! ----- Method: SHTextStylerST80>>privateStyle: (in category 'private') ----- privateStyle: aText | ranges | ranges := self rangesIn: aText setWorkspace: true. ranges ifNotNil: [self setAttributesIn: aText fromRanges: ranges]! ----- Method: SHTextStylerST80>>rangesIn:setWorkspace: (in category 'private') ----- rangesIn: aText setWorkspace: aBoolean "Answer a collection of SHRanges by parsing aText. When formatting it is not necessary to set the workspace, and this can make the parse take less time, so aBoolean specifies whether the parser should be given the workspace" | shoutParserClass | "Switch parsers if we have to" shoutParserClass := (classOrMetaClass ifNil:[Object]) shoutParserClass. parser class == shoutParserClass ifFalse:[parser := shoutParserClass new]. parser parseAMethod: parseAMethod. ^parser rangesIn: aText asString classOrMetaClass: classOrMetaClass workspace: (aBoolean ifTrue:[workspace]) environment: environment ! ----- Method: SHTextStylerST80>>replaceStringForRangesWithType:with:in: (in category 'private') ----- replaceStringForRangesWithType: aSymbol with: aString in: aText "Answer aText if no replacements, or a copy of aText with each range with a type of aSymbol replaced by aString" | answer toReplace adjustSourceMap increaseInLength | toReplace := (self rangesIn: aText setWorkspace: false) select: [:each | each type = aSymbol]. toReplace isEmpty ifTrue: [^aText]. answer := aText copy. increaseInLength := 0. adjustSourceMap := sourceMap notNil and:[sourceMap ~~ processedSourceMap]. (toReplace asSortedCollection: [:a :b | a start <= b start]) do: [:each | | end start thisIncrease | start := each start + increaseInLength. end := each end + increaseInLength. answer replaceFrom: start to: end with: aString. thisIncrease := aString size - each length. increaseInLength := increaseInLength + thisIncrease. adjustSourceMap ifTrue:[ sourceMap do:[:assoc | | first newFirst last newLast | first := newFirst := assoc value first. last := newLast := assoc value last. first > start ifTrue:[newFirst := first + thisIncrease]. last > start ifTrue:[newLast := last + thisIncrease]. (first ~= newFirst or:[last ~= newLast]) ifTrue:[assoc value: (newFirst to: newLast)]]]]. adjustSourceMap ifTrue:[processedSourceMap := sourceMap]. ^answer! ----- Method: SHTextStylerST80>>setAttributesIn:fromRanges: (in category 'private') ----- setAttributesIn: aText fromRanges: ranges | charAttr defaultAttr attr newRuns newValues lastAttr oldRuns lastCount | oldRuns := aText runs. defaultAttr := self attributesFor: #default. charAttr := Array new: aText size withAll: defaultAttr. ranges do: [ :range | (self attributesFor: range type) ifNotNil: [ :attribute | charAttr from: range start to: range end put: attribute ] ]. newRuns := OrderedCollection new: ranges size * 2 + 1. newValues := OrderedCollection new: ranges size * 2 + 1. lastAttr := nil. lastCount := 0. 1 to: charAttr size do: [ :i | (attr := charAttr at: i) == lastAttr ifTrue: [ lastCount := lastCount + 1. newRuns at: newRuns size put: lastCount ] ifFalse: [ newRuns addLast: 1. lastCount := 1. lastAttr := newValues addLast: attr ] ]. aText runs: (RunArray runs: newRuns values: newValues). oldRuns withStartStopAndValueDo:[:start :stop :attribs| (attribs anySatisfy: [ :each | each shoutShouldPreserve ]) ifTrue: [ attribs do: [ :each | aText addAttribute: each from: start to: stop ] ] ]. ! ----- Method: SHTextStylerST80>>sourceMap: (in category 'accessing') ----- sourceMap: aSortedCollection "set the receiver's sourceMap to aSortedCollection. The sourceMap is used by a Debugger to select the appropriate ranges within its text. These ranges need to be adjusted if, and when, the receiver reformats the text that is displayed" sourceMap := aSortedCollection! ----- Method: SHTextStylerST80>>unstyledTextFrom: (in category 'converting') ----- unstyledTextFrom: aText "Re-implemented so that TextActions are not removed from aText" | answer | answer := super unstyledTextFrom: aText. aText runs withStartStopAndValueDo: [:start :stop :attribs | (attribs anySatisfy: [:each | each isKindOf: TextAction]) ifTrue: [ attribs do: [:eachAttrib | answer addAttribute: eachAttrib from: start to: stop]]]. ^answer! ----- Method: SHTextStylerST80>>veryDeepInner: (in category 'copying') ----- veryDeepInner: aDeepCopier super veryDeepInner: aDeepCopier. classOrMetaClass := classOrMetaClass veryDeepCopyWith: aDeepCopier. workspace := workspace veryDeepCopyWith: aDeepCopier. "share the font?" parser := parser veryDeepCopyWith: aDeepCopier. sourceMap := sourceMap veryDeepCopyWith: aDeepCopier. processedSourceMap := processedSourceMap veryDeepCopyWith: aDeepCopier! ----- Method: SHTextStylerST80>>workspace: (in category 'accessing') ----- workspace: aWorkspace workspace := aWorkspace! ----- Method: Dictionary>>hasBindingThatBeginsWith: (in category '*ShoutCore') ----- hasBindingThatBeginsWith: aString "Answer true if the receiver has a key that begins with aString, false otherwise" self keysDo:[:each | (each beginsWith: aString) ifTrue:[^true]]. ^false! ----- Method: SharedPool class>>hasBindingThatBeginsWith: (in category '*ShoutCore') ----- hasBindingThatBeginsWith: aString "Answer true if the receiver has a binding that begins with aString, false otherwise" "First look in classVar dictionary." (self classPool hasBindingThatBeginsWith: aString) ifTrue:[^true]. "Next look in shared pools." self sharedPools do:[:pool | (pool hasBindingThatBeginsWith: aString) ifTrue: [^true]]. ^false! ----- Method: SystemDictionary>>hasBindingThatBeginsWith: (in category '*ShoutCore') ----- hasBindingThatBeginsWith: aString "Use the cached class and non-class names for better performance." | name searchBlock | searchBlock := [ :element | (element beginsWith: aString) ifTrue: [ 0 ] ifFalse: [ aString < element ifTrue: [ -1 ] ifFalse: [ 1 ] ] ]. name := self classNames findBinary: searchBlock ifNone: [ nil ]. name ifNotNil: [ ^true ]. name := self nonClassNames findBinary: searchBlock ifNone: [ nil ]. ^name notNil! ----- Method: SmalltalkImage>>hasBindingThatBeginsWith: (in category '*ShoutCore') ----- hasBindingThatBeginsWith: aString "Answer true if the receiver has a key that begins with aString, false otherwise" ^globals hasBindingThatBeginsWith: aString! ----- Method: Behavior>>shoutParserClass (in category '*ShoutCore-Parsing') ----- shoutParserClass "Answer the parser class" ^SHParserST80! ----- Method: Environment>>hasBindingThatBeginsWith: (in category '*ShoutCore') ----- hasBindingThatBeginsWith: aString bindings associationsDo: [:ea | (ea key beginsWith: aString) ifTrue: [^ true]]. ^ false ! ----- Method: Workspace>>hasBindingThatBeginsWith: (in category '*ShoutCore') ----- hasBindingThatBeginsWith: aString bindings ifNil: [ ^false ]. bindings keysDo: [ :each | (each beginsWith: aString) ifTrue: [ ^true ] ]. ^false!

1 0

Squeak 4.6: UpdateStream-nice.4.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of UpdateStream to project Squeak 4.6: http://source.squeak.org/squeak46/UpdateStream-nice.4.mcz ==================== Summary ==================== Name: UpdateStream-nice.4 Author: nice Time: 7 December 2013, 12:08:41.719 am UUID: 5fcdedce-88aa-469a-bf8b-32820f051c4f Ancestors: UpdateStream-fbs.3 Move some updateStream hooks in UpdateStream package This does not make the package properly removeable, because those hooks often are hardcoded So after removal, there will be some unimplemented sends ==================== Snapshot ==================== SystemOrganization addCategory: #UpdateStream! ----- Method: ServerDirectory class>>convertGroupNames (in category '*UpdateStream-server groups') ----- convertGroupNames "ServerDirectory convertGroupNames" self servers do: [:each | each convertGroupName]! ----- Method: ServerDirectory class>>groupNames (in category '*UpdateStream-server groups') ----- groupNames "Return the names of all registered groups of servers, including individual servers not in any group." "ServerDirectory groupNames" | names | names := Set new. self servers do: [:server | names add: server groupName]. ^names asSortedArray ! ----- Method: ServerDirectory class>>serverInGroupNamed: (in category '*UpdateStream-server groups') ----- serverInGroupNamed: groupName "Return the first (available) server in the group of this name." | servers | servers := self serversInGroupNamed: groupName. servers isEmpty ifTrue: [self error: 'No server found in group "' , groupName asString , '".']. ^servers first! ----- Method: ServerDirectory class>>serversInGroupNamed: (in category '*UpdateStream-server groups') ----- serversInGroupNamed: nameString "Return the servers in the group of this name." "ServerDirectory serversInGroupNamed: 'Squeak Public Updates' " ^self servers values select: [:server | nameString = server groupName]. ! ----- Method: ServerDirectory>>checkNames: (in category '*UpdateStream-updating') ----- checkNames: list "Look at these names for update and see if they are OK" list do: [:local | (local count: [:char | char == $.]) > 1 ifTrue: [ self inform: 'File name ',local,' may not have more than one period'. ^ false]. local size > 26 ifTrue: ["allows for 5 digit update numbers" self inform: 'File name ',local,' is too long. Please rename it.'. ^ false]. (local at: 1) isDigit ifTrue: [ self inform: 'File name ',local,' may not begin with a number'. ^ false]. (local findDelimiters: '%/* ' startingAt: 1) <= local size ifTrue: [ self inform: 'File name ',local,' may not contain % / * or space'. ^ false]]. ^ true ! ----- Method: ServerDirectory>>checkServersWithPrefix:andParseListInto: (in category '*UpdateStream-updating') ----- checkServersWithPrefix: prefix andParseListInto: listBlock "Check that all servers are up and have the latest Updates.list. Warn user when can't write to a server that can still be read. The contents of updates.list is parsed into {{vers. {fileNames*}}*}, and returned via the listBlock." | serverList updateLists listContents maxSize outOfDateServers | serverList := self serversInGroup. serverList isEmpty ifTrue: [^Array new]. updateLists := Dictionary new. serverList do: [:updateServer | [listContents := updateServer getFileNamed: prefix , 'updates.list'. updateLists at: updateServer put: listContents] on: Error do: [:ex | UIManager default chooseFrom: #('Cancel entire update') title: 'Server ', updateServer moniker, ' is unavailable.\Please consider phoning the administator.\' withCRs, listContents. ^Array new]]. maxSize := (updateLists collect: [:each | each size]) max. outOfDateServers := updateLists keys select: [:updateServer | (updateLists at: updateServer) size < maxSize]. outOfDateServers do: [:updateServer | (self outOfDate: updateServer) ifTrue: [^Array new]]. listBlock value: (UpdateStreamDownloader default parseListContents: listContents). serverList removeAll: outOfDateServers. ^serverList ! ----- Method: ServerDirectory>>closeGroup (in category '*UpdateStream-server groups') ----- closeGroup "Close connection with all servers in the group." self serversInGroup do: [:aDir | aDir quit]. ! ----- Method: ServerDirectory>>convertGroupName (in category '*UpdateStream-server groups') ----- convertGroupName group ifNotNil: [self groupName: self groupName]! ----- Method: ServerDirectory>>copyUpdatesNumbered:toVersion: (in category '*UpdateStream-updating') ----- copyUpdatesNumbered: selectList toVersion: otherVersion "Into the section of updates.list corresponding to otherVersion, copy all the fileNames from this version matching the selectList." " (ServerDirectory serverInGroupNamed: 'Disney Internal Updates*') copyUpdatesNumbered: #(4411 4412) to version: 'Squeak3.1beta'. " | myServers updateStrm indexPrefix version versIndex lastNum otherVersIndex additions outOfOrder listContents | self openGroup. indexPrefix := (self groupName includes: $*) ifTrue: [(self groupName findTokens: ' ') first] "special for internal updates" ifFalse: ['']. "normal" myServers := self checkServersWithPrefix: indexPrefix andParseListInto: [:x | listContents := x]. myServers size = 0 ifTrue: [self closeGroup. ^ self]. version := SystemVersion current version. versIndex := (listContents collect: [:pair | pair first]) indexOf: version. versIndex = 0 ifTrue: [self inform: 'There is no section in updates.list for your version'. self closeGroup. ^ nil]. "abort" otherVersIndex := (listContents collect: [:pair | pair first]) indexOf: otherVersion. otherVersIndex = 0 ifTrue: [self inform: 'There is no section in updates.list for the target version'. self closeGroup. ^ nil]. "abort" versIndex < listContents size ifTrue: [(self confirm: 'This system, ', version , ' is not the latest version.\OK to copy updates from that old version?' withCRs) ifFalse: [self closeGroup. ^ nil]]. "abort" "Append all fileNames in my list that are not in the export list" additions := OrderedCollection new. outOfOrder := OrderedCollection new. lastNum := (listContents at: otherVersIndex) last isEmpty ifTrue: [0] "no checking if the current list is empty" ifFalse: [(listContents at: otherVersIndex) last last initialIntegerOrNil]. (listContents at: versIndex) last do: [:fileName | | seq | seq := fileName initialIntegerOrNil. (selectList includes: seq) ifTrue: [seq > lastNum ifTrue: [additions addLast: fileName] ifFalse: [outOfOrder addLast: seq]]]. outOfOrder isEmpty ifFalse: [UIManager default inform: 'Updates numbered ' , outOfOrder asArray printString, ' are out of order.\ The last update in ' withCRs, otherVersion, ' is ', lastNum printString, '.\No update will take place.' withCRs. self closeGroup. ^ nil]. "abort" "Save old copy of updates.list on local disk" FileDirectory default deleteFileNamed: indexPrefix , 'updates.list.bk'. UpdateStreamDownloader default writeList: listContents toStream: (FileStream fileNamed: indexPrefix , 'updates.list.bk'). "Write a new copy of updates.list on all servers..." listContents at: otherVersIndex put: {otherVersion. (listContents at: otherVersIndex) last , additions}. updateStrm := ReadStream on: (String streamContents: [:s | Utilities writeList: listContents toStream: s]). myServers do: [:aServer | updateStrm reset. aServer putFile: updateStrm named: indexPrefix , 'updates.list' retry: true. Transcript show: 'Update succeeded on server ', aServer moniker; cr]. self closeGroup. Transcript cr; show: 'Be sure to test your new update!!'; cr. ! ----- Method: ServerDirectory>>exportUpdatesExcept: (in category '*UpdateStream-updating') ----- exportUpdatesExcept: skipList "Into the section of updates.list corresponding to this version, copy all the fileNames in the named updates.list for this group that are more recently numbered." " (ServerDirectory serverInGroupNamed: 'Disney Internal Updates*') exportUpdatesExcept: #(3959). " | myServers updateStrm response indexPrefix version versIndex lastNum expContents expVersIndex additions listContents | self openGroup. indexPrefix := (self groupName includes: $*) ifTrue: [(self groupName findTokens: ' ') first] "special for internal updates" ifFalse: ['']. "normal" myServers := self checkServersWithPrefix: indexPrefix andParseListInto: [:x | listContents := x]. myServers size = 0 ifTrue: [self closeGroup. ^ self]. version := SystemVersion current version. versIndex := (listContents collect: [:pair | pair first]) indexOf: version. versIndex = 0 ifTrue: [self inform: 'There is no section in updates.list for your version'. self closeGroup. ^ nil]. "abort" versIndex < listContents size ifTrue: [response := UIManager default chooseFrom: #('Make update from an older version' 'Cancel update') title: 'This system, ', SystemVersion current version, ' is not the latest version'. response = 1 ifFalse: [self closeGroup. ^ nil]]. "abort" "Get the old export updates.list." expContents := UpdateStreamDownloader default parseListContents: (myServers first getFileNamed: 'updates.list'). expVersIndex := (expContents collect: [:pair | pair first]) indexOf: version. expVersIndex = 0 ifTrue: [self inform: 'There is no section in updates.list for your version'. self closeGroup. ^ nil]. "abort" lastNum := (expContents at: expVersIndex) last isEmpty ifTrue: [0] "no checking if the current list is empty" ifFalse: [(expContents at: expVersIndex) last last initialIntegerOrNil]. "Save old copy of updates.list on local disk" FileDirectory default deleteFileNamed: 'updates.list.bk'. UpdateStreamDownloader default writeList: expContents toStream: (FileStream fileNamed: 'updates.list.bk'). "Append all fileNames in my list that are not in the export list" additions := OrderedCollection new. (listContents at: versIndex) last do: [:fileName | | seq | seq := fileName initialIntegerOrNil. (seq > lastNum and: [(skipList includes: seq) not]) ifTrue: [additions addLast: fileName]]. expContents at: expVersIndex put: {version. (expContents at: expVersIndex) last , additions}. (self confirm: 'Do you really want to export ' , additions size printString , ' recent updates?') ifFalse: [self closeGroup. ^ nil]. "abort" "Write a new copy of updates.list on all servers..." updateStrm := ReadStream on: (String streamContents: [:s | Utilities writeList: expContents toStream: s]). myServers do: [:aServer | updateStrm reset. aServer putFile: updateStrm named: 'updates.list' retry: true. Transcript show: 'Update succeeded on server ', aServer moniker; cr]. self closeGroup. Transcript cr; show: 'Be sure to test your new update!!'; cr. ! ----- Method: ServerDirectory>>openGroup (in category '*UpdateStream-server groups') ----- openGroup "Open all servers in the group. Don't forget to close later." self serversInGroup do: [:aDir | aDir wakeUp]. ! ----- Method: ServerDirectory>>outOfDate: (in category '*UpdateStream-updating') ----- outOfDate: aServer "Inform the user that this server does not have a current version of 'Updates.list' Return true if the user does not want any updates to happen." | response | response := UIManager default chooseFrom: #('Install on others' 'Cancel entire update') title: 'The server ', aServer moniker, ' is not up to date. Please store the missing updates maually.'. ^ response ~= 1! ----- Method: ServerDirectory>>putUpdate: (in category '*UpdateStream-updating') ----- putUpdate: fileStrm "Put this file out as an Update on the servers of my group. Each version of the system may have its own set of update files, or they may all share the same files. 'updates.list' holds the master list. Each update is a fileIn whose name begins with a number. See Utilities class readServerUpdatesThrough:saveLocally:updateImage:. When two sets of updates are stored on the same directory, one of them has a * in its serverUrls description. When that is true, the first word of the description is put on the front of 'updates.list', and that index file is used." | myServers updateStrm newName response localName seq indexPrefix listContents version versIndex lastNum stripped | localName := fileStrm localName. fileStrm size = 0 ifTrue: [^ self inform: 'That file has zero bytes!! May have a new name.']. (fileStrm contentsOfEntireFile includes: Character linefeed) ifTrue: [self notifyWithLabel: 'That file contains linefeeds. Proceed if... you know that this is okay (e.g. the file contains raw binary data).']. fileStrm reset. (self checkNames: {localName}) ifFalse: [^ nil]. "illegal characters" response := UIManager default chooseFrom: #('Install update' 'Cancel update') title: 'Do you really want to broadcast the file ', localName, '\to every Squeak user who updates from ' withCRs, self groupName, '?'. response = 1 ifFalse: [^ nil]. "abort" self openGroup. indexPrefix := (self groupName includes: $*) ifTrue: [(self groupName findTokens: ' ') first] "special for internal updates" ifFalse: ['']. "normal" myServers := self checkServersWithPrefix: indexPrefix andParseListInto: [:x | listContents := x]. myServers size = 0 ifTrue: [self closeGroup. ^ self]. version := SystemVersion current version. versIndex := (listContents collect: [:pair | pair first]) indexOf: version. versIndex = 0 ifTrue: [self inform: 'There is no section in updates.list for your version'. self closeGroup. ^ nil]. "abort" "A few affirmations..." versIndex < listContents size ifTrue: [(self confirm: 'This system, ', version , ' is not the latest version.\Make update for an older version?' withCRs) ifFalse: [self closeGroup. ^ nil]]. "abort" (listContents at: versIndex) last isEmpty ifTrue: [(self confirm: 'Please confirm that you mean to issue the first update for ' , version , '\(otherwise something is wrong).' withCRs) ifFalse: [self closeGroup. ^ nil]]. "We now determine next update number to be max of entire index" lastNum := listContents inject: 0 into: [:max :pair | pair last isEmpty ifTrue: [max] ifFalse: [max max: pair last last initialIntegerOrNil]]. "Save old copy of updates.list on local disk" FileDirectory default deleteFileNamed: indexPrefix , 'updates.list.bk'. UpdateStreamDownloader default writeList: listContents toStream: (FileStream fileNamed: indexPrefix , 'updates.list.bk'). "append name to updates with new sequence number" seq := (lastNum + 1) printString padded: #left to: 4 with: $0. "strip off any old seq number" stripped := localName copyFrom: (localName findFirst: [:c | c isDigit not]) to: localName size. newName := seq , stripped. listContents at: versIndex put: {version. (listContents at: versIndex) last copyWith: newName}. "Write a new copy on all servers..." updateStrm := ReadStream on: (String streamContents: [:s | Utilities writeList: listContents toStream: s]). myServers do: [:aServer | fileStrm reset. "reopen" aServer putFile: fileStrm named: newName retry: true. updateStrm reset. aServer putFile: updateStrm named: indexPrefix , 'updates.list' retry: true. Transcript show: 'Update succeeded on server ', aServer moniker; cr]. self closeGroup. Transcript cr; show: 'Be sure to test your new update!!'; cr. "rename the file locally (may fail)" fileStrm directory rename: localName toBe: newName. ! ----- Method: ServerDirectory>>putUpdateMulti:fromDirectory: (in category '*UpdateStream-updating') ----- putUpdateMulti: list fromDirectory: updateDirectory "Put these files out as an Update on the servers of my group. List is an array of local file names with or without number prefixes. Each version of the system has its own set of update files. 'updates.list' holds the master list. Each update is a fileIn whose name begins with a number. See Utilities class absorbUpdatesFromServer." | myServers updateStrm lastNum response newNames numStr indexPrefix version versIndex listContents | (self checkNames: (list collect: "Check the names without their numbers" [:each | each copyFrom: (each findFirst: [:c | c isDigit not]) to: each size])) ifFalse: [^ nil]. response := UIManager default chooseFrom: #('Install update' 'Cancel update') title: 'Do you really want to broadcast ', list size printString, ' updates', '\to every Squeak user who updates from ' withCRs, self groupName, '?'. response = 1 ifFalse: [^ nil]. "abort" self openGroup. indexPrefix := (self groupName includes: $*) ifTrue: [(self groupName findTokens: ' ') first] "special for internal updates" ifFalse: ['']. "normal" myServers := self checkServersWithPrefix: indexPrefix andParseListInto: [:x | listContents := x]. myServers size = 0 ifTrue: [self closeGroup. ^ self]. version := SystemVersion current version. versIndex := (listContents collect: [:pair | pair first]) indexOf: version. versIndex = 0 ifTrue: [self inform: 'There is no section in updates.list for your version'. self closeGroup. ^ nil]. "abort" lastNum := (listContents at: versIndex) last last initialIntegerOrNil. versIndex < listContents size ifTrue: [response := UIManager default chooseFrom: #('Make update for an older version' 'Cancel update') title: 'This system, ', SystemVersion current version, ' is not the latest version'. response = 1 ifFalse: [self closeGroup. ^ nil]. numStr := UIManager default request: 'Please confirm or change the starting update number' initialAnswer: (lastNum+1) printString. lastNum := numStr asNumber - 1]. "abort" "Save old copy of updates.list on local disk" FileDirectory default deleteFileNamed: indexPrefix , 'updates.list.bk'. UpdateStreamDownloader default writeList: listContents toStream: (FileStream fileNamed: indexPrefix , 'updates.list.bk'). "Append names to updates with new sequence numbers" newNames := list with: (lastNum+1 to: lastNum+list size) collect: [:each :num | | stripped seq | seq := num printString padded: #left to: 4 with: $0. "strip off any old seq number" stripped := each copyFrom: (each findFirst: [:c | c isDigit not]) to: each size. seq , stripped]. listContents at: versIndex put: {version. (listContents at: versIndex) second , newNames}. "Write a new copy on all servers..." updateStrm := ReadStream on: (String streamContents: [:s | Utilities writeList: listContents toStream: s]). myServers do: [:aServer | list doWithIndex: [:local :ind | | file | file := updateDirectory oldFileNamed: local. aServer putFile: file named: (newNames at: ind) retry: true. file close]. updateStrm reset. aServer putFile: updateStrm named: indexPrefix , 'updates.list' retry: true. Transcript show: 'Update succeeded on server ', aServer moniker; cr]. self closeGroup. Transcript cr; show: 'Be sure to test your new update!!'; cr. "rename the file locally" list with: newNames do: [:local :newName | updateDirectory rename: local toBe: newName]. ! ----- Method: ServerDirectory>>serversInGroup (in category '*UpdateStream-server groups') ----- serversInGroup ^self groupName ifNil: [Array with: self] ifNotNil: [self class serversInGroupNamed: self groupName]! ----- Method: ServerDirectory>>updateInstallVersion: (in category '*UpdateStream-updating') ----- updateInstallVersion: newVersion "For each server group, ask whether we want to put the new version marker (eg 'Squeak2.3') at the end of the file. Current version of Squeak must be the old one when this is done. ServerDirectory new updateInstallVersion: 'Squeak9.9test' " | myServers updateStrm names choice indexPrefix listContents version versIndex | [names := ServerDirectory groupNames asSortedArray. choice := UIManager default chooseFrom: names values: names. choice == nil] whileFalse: [indexPrefix := (choice endsWith: '*') ifTrue: [(choice findTokens: ' ') first] "special for internal updates" ifFalse: ['']. "normal" myServers := (ServerDirectory serverInGroupNamed: choice) checkServersWithPrefix: indexPrefix andParseListInto: [:x | listContents := x]. myServers size = 0 ifTrue: [^ self]. version := SystemVersion current version. versIndex := (listContents collect: [:pair | pair first]) indexOf: version. versIndex = 0 ifTrue: [^ self inform: 'There is no section in updates.list for your version']. "abort" "Append new version to updates following my version" listContents := listContents copyReplaceFrom: versIndex+1 to: versIndex with: {{newVersion. {}}}. updateStrm := ReadStream on: (String streamContents: [:s | UpdateStreamDownloader default writeList: listContents toStream: s]). myServers do: [:aServer | updateStrm reset. aServer putFile: updateStrm named: indexPrefix ,'updates.list'. Transcript cr; show: indexPrefix ,'updates.list written on server ', aServer moniker]. self closeGroup]! ----- Method: ImageReadWriter class>>formFromServerFile: (in category '*UpdateStream') ----- formFromServerFile: fileName "Answer a ColorForm stored on the file with the given name. Meant to be called from during the getting of updates from the server. That assures that (UpdateStreamDownloader default serverUrls) returns the right group of servers." | urls | urls := UpdateStreamDownloader default serverUrls collect: [:url | url, fileName]. " fileName starts with: 'updates/' " urls do: [:aURL | | form doc | (fileName findTokens: '.') last asLowercase = 'gif' ifTrue: [ form := HTTPSocket httpGif: aURL. form = (ColorForm extent: 20@20 depth: 8) ifTrue: [self inform: 'The file ',aURL,' is ill formed.']. ^ form]. (fileName findTokens: '.') last asLowercase = 'bmp' ifTrue: [ doc := HTTPSocket httpGet: aURL accept: 'image/bmp'. form := Form fromBMPFile: doc. doc close. form ifNil: [self inform: 'The file ',aURL,' is ill formed.'. ^ Form new] ifNotNil: [^ form]]. self inform: 'File ', fileName, 'does not end with .gif or .bmp']. self inform: 'That file not found on any server we know'.! Object subclass: #UpdateStreamDownloader instanceVariableNames: '' classVariableNames: 'PromptForUpdateServer UpdateDownloader UpdateSavesFile UpdateUrlLists' poolDictionaries: '' category: 'UpdateStream'! ----- Method: UpdateStreamDownloader class>>applyUpdatesFromDisk (in category 'fetching updates') ----- applyUpdatesFromDisk "UpdateStreamDownloader applyUpdatesFromDisk" "compute highest update number" | updateDirectory updateNumbers | updateDirectory := self getUpdateDirectoryOrNil. updateDirectory ifNil: [^ self]. updateNumbers := updateDirectory fileNames collect: [:fn | fn initialIntegerOrNil] thenSelect: [:fn | fn notNil]. self applyUpdatesFromDiskToUpdateNumber: (updateNumbers inject: 0 into: [:max :num | max max: num]) stopIfGap: false! ----- Method: UpdateStreamDownloader class>>applyUpdatesFromDiskToUpdateNumber:stopIfGap: (in category 'fetching updates') ----- applyUpdatesFromDiskToUpdateNumber: lastUpdateNumber stopIfGap: stopIfGapFlag "To use this mechanism, be sure all updates you want to have considered are in a folder named 'updates' which resides in the same directory as your image. Having done that, simply evaluate: UpdateStreamDownloader applyUpdatesFromDiskToUpdateNumber: 1234 stopIfGap: false and all numbered updates <= lastUpdateNumber not yet in the image will be loaded in numerical order." | previousHighest currentUpdateNumber done fileNames aMessage updateDirectory loaded | updateDirectory := self getUpdateDirectoryOrNil. updateDirectory ifNil: [^ self]. previousHighest := SystemVersion current highestUpdate. currentUpdateNumber := previousHighest. done := false. loaded := 0. [done] whileFalse: [currentUpdateNumber := currentUpdateNumber + 1. currentUpdateNumber > lastUpdateNumber ifTrue: [done := true] ifFalse: [fileNames := updateDirectory fileNamesMatching: currentUpdateNumber printString , '*'. fileNames size > 1 ifTrue: [^ self inform: 'ambiguity -- two files both start with ' , currentUpdateNumber printString , ' (at this point it is probably best to remedy the situation on disk, then try again.)']. fileNames size = 0 ifTrue: [Transcript cr; show: 'gap in updates from disk for update number '; print: currentUpdateNumber; show: ' found...'. done := stopIfGapFlag] ifFalse: [ChangeSet newChangesFromStream: (updateDirectory readOnlyFileNamed: fileNames first) named: fileNames first. SystemVersion current registerUpdate: currentUpdateNumber. loaded := loaded + 1]]]. aMessage := loaded = 0 ifTrue: ['No new updates found.'] ifFalse: [loaded printString , ' update(s) loaded.']. self inform: aMessage , ' Highest numbered update is now ' , (currentUpdateNumber - 1) printString , '.'! ----- Method: UpdateStreamDownloader class>>assureAbsenceOfUnstableUpdateStream (in category 'server urls') ----- assureAbsenceOfUnstableUpdateStream "Check to see if the unstable Updates stream is in the list; if it is, *remove* it. This is the *opposite* of #assureAvailabilityOfUnstableUpdateStream" UpdateUrlLists ifNil: [UpdateUrlLists := OrderedCollection new]. UpdateUrlLists := UpdateUrlLists select: [:pair | pair first ~= 'Unstable Updates*'] "UpdateStreamDownloader assureAbsenceOfUnstableUpdateStream"! ----- Method: UpdateStreamDownloader class>>assureAvailabilityOfSqueakPublicUpdateStream (in category 'server urls') ----- assureAvailabilityOfSqueakPublicUpdateStream "Check to see if the Squeak public Updates stream is in the list; if not, add it" UpdateUrlLists ifNil: [UpdateUrlLists := OrderedCollection new]. UpdateUrlLists do: [:pair | (pair first = 'Squeak Public Updates') ifTrue: [^ self]]. UpdateUrlLists addFirst: #('Squeak Public Updates' #('ftp.squeak.org/')) "UpdateStreamDownloader assureAvailabilityOfSqueakPublicUpdateStream"! ----- Method: UpdateStreamDownloader class>>assureAvailabilityOfUnstableUpdateStream (in category 'server urls') ----- assureAvailabilityOfUnstableUpdateStream "Check to see if the unstable Updates stream is in the list; if not, add it" UpdateUrlLists ifNil: [UpdateUrlLists := OrderedCollection new]. UpdateUrlLists do: [:pair | (pair first = 'Unstable Updates*') ifTrue: [^ self]]. UpdateUrlLists addFirst: #('Unstable Updates*' #('squeak.cs.uiuc.edu/Squeak2.0/' 'update.squeakfoundation.org/external/')) "UpdateStreamDownloader assureAvailabilityOfUnstableUpdateStream"! ----- Method: UpdateStreamDownloader class>>broadcastUpdatesFrom:to:except: (in category 'fetching updates') ----- broadcastUpdatesFrom: n1 to: n2 except: skipList " Note: This method takes its list of files from the directory named 'updates', which will have been created and filled by, eg, UpdateStreamDownloader readServerUpdatesSaveLocally: true updateImage: true. These can then be rebroadcast to any server using, eg, UpdateStreamDownloader broadcastUpdatesFrom: 1 to: 9999 except: #(223 224). If the files are already on the server, and it is only a matter of copying them to the index for a different version, then use... (ServerDirectory serverInGroupNamed: 'SqC Internal Updates*') exportUpdatesExcept: #(). " | fileNames fileNamesInOrder names choice file updateDirectory | updateDirectory := FileDirectory default directoryNamed: 'updates'. fileNames := updateDirectory fileNames select: [:n | n first isDigit and: [(n initialIntegerOrNil between: n1 and: n2) and: [(skipList includes: n initialIntegerOrNil) not]]]. (file := fileNames select: [:n | (n occurrencesOf: $.) > 1]) size > 0 ifTrue: [self halt: file first , ' has multiple periods']. fileNamesInOrder := fileNames asSortedCollection: [:a :b | a initialIntegerOrNil < b initialIntegerOrNil]. names := ServerDirectory groupNames asSortedArray. choice := UIManager default chooseFrom: names values: names. choice == nil ifTrue: [^ self]. (ServerDirectory serverInGroupNamed: choice) putUpdateMulti: fileNamesInOrder fromDirectory: updateDirectory ! ----- Method: UpdateStreamDownloader class>>chooseUpdateList (in category 'fetching updates') ----- chooseUpdateList "When there is more than one set of update servers, let the user choose which we will update from. Put it at the front of the list. Return false if the user aborted. If the preference #promptForUpdateServer is false, then suppress that prompt, in effect using the same server choice that was used the previous time (a convenience for those of us who always answer the same thing to the prompt.)" | index him | ((UpdateUrlLists size > 1) and: [self promptForUpdateServer]) ifTrue: [index := UIManager default chooseFrom: (UpdateUrlLists collect: [:each | each first]) lines: #() title: 'Choose a group of servers\from which to fetch updates.' translated withCRs. index > 0 ifTrue: [him := UpdateUrlLists at: index. UpdateUrlLists removeAt: index. UpdateUrlLists addFirst: him]. ^ index > 0]. ^ true! ----- Method: UpdateStreamDownloader class>>default (in category 'accessing') ----- default "Answer the default downloader. Currently, all methods are at class side, so it'll be ourself" ^self! ----- Method: UpdateStreamDownloader class>>extractThisVersion: (in category 'fetching updates') ----- extractThisVersion: list "Pull out the part of the list that applies to this version." | listContents version versIndex | listContents := self parseListContents: list. version := SystemVersion current version. versIndex := (listContents collect: [:pair | pair first]) indexOf: version. versIndex = 0 ifTrue: [^ Array new]. "abort" ^ (listContents at: versIndex) last! ----- Method: UpdateStreamDownloader class>>fileInFromUpdatesFolder: (in category 'fetching updates') ----- fileInFromUpdatesFolder: numberList "File in a series of updates with the given updates numbers, from the updates folder in the default directory. The file-ins are done in numeric order, even if numberList was not sorted upon entry. This is useful for test-driving the retrofitting of a possibly discontinguous list of updates from an alpha version back to a stable release. UpdateStreamDownloader fileInFromUpdatesFolder: #(4745 4746 4747 4748 4749 4750 4751 4752 4754 4755 4761 4762 4767 4769). " | fileNames fileNamesInOrder file updateDirectory | updateDirectory := FileDirectory default directoryNamed: 'updates'. fileNames := updateDirectory fileNames select: [:n | n first isDigit and: [numberList includes: n initialIntegerOrNil]]. (file := fileNames select: [:n | (n occurrencesOf: $.) > 1]) size > 0 ifTrue: [self error: file first , ' has multiple periods']. fileNamesInOrder := fileNames asSortedCollection: [:a :b | a initialIntegerOrNil < b initialIntegerOrNil]. fileNamesInOrder do: [:aFileName | (updateDirectory readOnlyFileNamed: aFileName) fileIntoNewChangeSet]! ----- Method: UpdateStreamDownloader class>>getUpdateDirectoryOrNil (in category 'fetching updates') ----- getUpdateDirectoryOrNil ^ (FileDirectory default directoryNames includes: 'updates') ifTrue: [FileDirectory default directoryNamed: 'updates'] ifFalse: [self inform: 'Error: cannot find "updates" folder'. nil]! ----- Method: UpdateStreamDownloader class>>lastUpdateNum: (in category 'fetching updates') ----- lastUpdateNum: updatesFileStrm "Look in the Updates file and see what the last sequence number is. Warn the user if the version it is under is not this image's version." | verIndex seqIndex char ver seqNum | verIndex := seqIndex := 0. "last # starting a line and last digit starting a line" seqNum := 0. updatesFileStrm reset; ascii. [char := updatesFileStrm next. updatesFileStrm atEnd] whileFalse: [ char == Character cr ifTrue: [ updatesFileStrm peek == $# ifTrue: [verIndex := updatesFileStrm position +1. seqIndex = 0 ifFalse: ["See if last num of old version if biggest so far" updatesFileStrm position: seqIndex. ver := SmallInteger readFrom: updatesFileStrm. seqNum := seqNum max: ver. updatesFileStrm position: verIndex-1]]. updatesFileStrm peek isDigit ifTrue: [seqIndex := updatesFileStrm position]]]. seqIndex = 0 ifFalse: ["See if last num of old version if biggest so far" updatesFileStrm position: seqIndex. ver := SmallInteger readFrom: updatesFileStrm. seqNum := seqNum max: ver. updatesFileStrm setToEnd]. ^ seqNum! ----- Method: UpdateStreamDownloader class>>newUpdatesOn:special:throughNumber: (in category 'fetching updates') ----- newUpdatesOn: serverList special: indexPrefix throughNumber: aNumber "Return a list of fully formed URLs of update files we do not yet have. Go to the listed servers and look at the file 'updates.list' for the names of the last N update files. We look backwards for the first one we have, and make the list from there. tk 9/10/97 No updates numbered higher than aNumber (if it is not nil) are returned " | existing out maxNumber | maxNumber := aNumber ifNil: [99999]. out := OrderedCollection new. existing := SystemVersion current updates. serverList do: [:server | | raw doc list char | doc := HTTPClient httpGet: 'http://' , server,indexPrefix,'updates.list'. "test here for server being up" doc class == RWBinaryOrTextStream ifTrue: [raw := doc reset; contents. "one file name per line" list := self extractThisVersion: raw. list reverseDo: [:fileName | | ff itsNumber | ff := (fileName findTokens: '/') last. "allow subdirectories" itsNumber := ff initialIntegerOrNil. (existing includes: itsNumber) ifFalse: [ (itsNumber == nil or: [itsNumber <= maxNumber]) ifTrue: [out addFirst: 'http://' , server, fileName]] ifTrue: [^ out]]. ((out size > 0) or: [char := doc reset; skipSeparators; next. (char == $*) | (char == $#)]) ifTrue: [^ out "we have our list"]]. "else got error msg instead of file" "Server was down, try next one"]. self inform: 'All code update servers seem to be unavailable'. ^ out! ----- Method: UpdateStreamDownloader class>>objectStrmFromUpdates: (in category 'fetching updates') ----- objectStrmFromUpdates: fileName "Go to the known servers and look for this file in the updates folder. It is an auxillery file, like .morph or a .gif. Return a RWBinaryOrTextStream on it. Meant to be called from during the getting of updates from the server. That assures that (UpdateStreamDownloader serverUrls) returns the right group of servers." Cursor wait showWhile: [ | urls | urls := UpdateStreamDownloader serverUrls collect: [:url | url, 'updates/', fileName]. urls do: [:aUrl | | doc | doc := HTTPSocket httpGet: aUrl accept: 'application/octet-stream'. "test here for server being up" doc class == RWBinaryOrTextStream ifTrue: [^ doc reset]]]. self inform: 'All update servers are unavailable, or bad file name'. ^ nil! ----- Method: UpdateStreamDownloader class>>parseListContents: (in category 'fetching updates') ----- parseListContents: listContents | sections vers strm line fileNames | "Parse the contents of updates.list into {{vers. {fileNames*}}*}, and return it." sections := OrderedCollection new. fileNames := OrderedCollection new: 1000. vers := nil. strm := ReadStream on: listContents. [strm atEnd] whileFalse: [line := strm nextLine. line size > 0 ifTrue: [line first = $# ifTrue: [vers ifNotNil: [sections addLast: {vers. fileNames asArray}]. "Start a new section" vers := line allButFirst. fileNames resetTo: 1] ifFalse: [line first = $* ifFalse: [fileNames addLast: line]]]]. vers ifNotNil: [sections addLast: {vers. fileNames asArray}]. ^ sections asArray " TEST: | list | list := UpdateStreamDownloader parseListContents: (FileStream oldFileNamed: 'updates.list') contentsOfEntireFile. list = (UpdateStreamDownloader parseListContents: (String streamContents: [:s | UpdateStreamDownloader writeList: list toStream: s])) ifFalse: [self error: 'test failed'] ifTrue: [self inform: 'test OK'] "! ----- Method: UpdateStreamDownloader class>>position:atVersion: (in category 'fetching updates') ----- position: updateStrm atVersion: version "Set the stream to the end of the last line of updates names for this version. Usually the end of the file. We will add a new update name. Return the contents of the rest of the file." | char foundIt where data | updateStrm reset; ascii. foundIt := false. [char := updateStrm next. updateStrm atEnd] whileFalse: [ (char == Character cr or: [char == Character lf]) ifTrue: [ updateStrm peek == $# ifTrue: [ foundIt ifTrue: ["Next section" where := updateStrm position. data := updateStrm upTo: (255 asCharacter). updateStrm position: where. ^ data]. "won't be found -- copy all the way to the end" updateStrm next. (updateStrm nextMatchAll: version) ifTrue: [ (updateStrm atEnd or: [(updateStrm peek = Character cr) | (updateStrm peek = Character lf)]) ifTrue: [ foundIt := true ]]]]]. foundIt ifTrue: [ updateStrm setToEnd. ^ '']. self error: 'The current version does not have a section in the Updates file'. ! ----- Method: UpdateStreamDownloader class>>promptForUpdateServer (in category 'preferences') ----- promptForUpdateServer <preference: 'Prompt for update server' category: 'updates' description: 'If false, the prompt for server choice when updating code from the server is suppressed. Set this to false to leave the server choice unchanged from update to update.' type: #Boolean> ^PromptForUpdateServer ifNil: [ false ]! ----- Method: UpdateStreamDownloader class>>promptForUpdateServer: (in category 'preferences') ----- promptForUpdateServer: aBoolean PromptForUpdateServer := aBoolean! ----- Method: UpdateStreamDownloader class>>readNextUpdateFromServer (in category 'fetching updates') ----- readNextUpdateFromServer "UpdateStreamDownloader readNextUpdateFromServer" self updateFromServerThroughUpdateNumber: (ChangeSet highestNumberedChangeSet + 1)! ----- Method: UpdateStreamDownloader class>>readNextUpdatesFromDisk: (in category 'fetching updates') ----- readNextUpdatesFromDisk: n "Read the updates up through the current highest-update-number plus n. Thus, UpdateStreamDownloader readNextUpdatesFromDisk: 7 will read the next seven updates from disk" self applyUpdatesFromDiskToUpdateNumber: ChangeSet highestNumberedChangeSet + n stopIfGap: false! ----- Method: UpdateStreamDownloader class>>readServer:special:updatesThrough:saveLocally:updateImage: (in category 'fetching updates') ----- readServer: serverList special: indexPrefix updatesThrough: maxNumber saveLocally: saveLocally updateImage: updateImage "Scan the update server(s) for unassimilated updates. If maxNumber is not nil, it represents the highest-numbered update to load. This makes it possible to update only up to a particular point. If saveLocally is true, then save local copies of the update files on disc. If updateImage is true, then absorb the updates into the current image." "UpdateStreamDownloader readServer: UpdateStreamDownloader serverUrls updatesThrough: 828 saveLocally: true updateImage: true" | str urls failed loaded | Cursor wait showWhile: [ | docQueue docQueueSema | urls := self newUpdatesOn: (serverList collect: [:url | url, 'updates/']) special: indexPrefix throughNumber: maxNumber. loaded := 0. failed := nil. "send downloaded documents throuh this queue" docQueue := SharedQueue new. "this semaphore keeps too many documents from beeing queueed up at a time" docQueueSema := Semaphore new. 5 timesRepeat: [ docQueueSema signal ]. "fork a process to download the updates" self retrieveUrls: urls ontoQueue: docQueue withWaitSema: docQueueSema. "process downloaded updates in the foreground" 'Processing updates' displayProgressFrom: 0 to: urls size during: [:bar | | nextDoc this updateName | [ this := docQueue next. nextDoc := docQueue next. nextDoc = #failed ifTrue: [ failed := this ]. (failed isNil and: [ nextDoc ~= #finished ]) ] whileTrue: [ failed ifNil: [ nextDoc reset; text. nextDoc size = 0 ifTrue: [ failed := this ]. ]. failed ifNil: [ nextDoc peek asciiValue = 4 "pure object file" ifTrue: [failed := this]]. "Must be fileIn, not pure object file" failed ifNil: [ "(this endsWith: '.html') ifTrue: [doc := doc asHtml]." "HTML source code not supported here yet" updateImage ifTrue: [ updateName := (this findTokens: '/') last. ChangeSet newChangesFromStream: nextDoc named: updateName. SystemVersion current registerUpdate: updateName initialIntegerOrNil]. saveLocally ifTrue: [self saveUpdate: nextDoc onFile: (this findTokens: '/') last]. "if wanted" loaded := loaded + 1. bar value: loaded]. docQueueSema signal]. ]]. failed ~~ nil & (urls size - loaded > 0) ifTrue: [ str := loaded printString ,' new update file(s) processed.'. str := str, '\Could not load ' withCRs, (urls size - loaded) printString ,' update file(s).', '\Starting with "' withCRs, failed, '".'. self inform: str]. ^ Array with: failed with: loaded ! ----- Method: UpdateStreamDownloader class>>readServerUpdatesSaveLocally:updateImage: (in category 'fetching updates') ----- readServerUpdatesSaveLocally: saveLocally updateImage: updateImage ^ self readServerUpdatesThrough: nil saveLocally: saveLocally updateImage: updateImage! ----- Method: UpdateStreamDownloader class>>readServerUpdatesThrough:saveLocally:updateImage: (in category 'fetching updates') ----- readServerUpdatesThrough: maxNumber saveLocally: saveLocally updateImage: updateImage "Scan the update server(s) for unassimilated updates. If maxNumber is not nil, it represents the highest-numbered update to load. This makes it possible to update only up to a particular point. If saveLocally is true, then save local copies of the update files on disc. If updateImage is true, then absorb the updates into the current image. A file on the server called updates.list has the names of the last N update files. We look backwards for the first one we do not have, and start there" "* To add a new update: Name it starting with a new two-digit code. * Do not use %, /, *, space, or more than one period in the name of an update file. * The update name does not need to have any relation to the version name. * Figure out which versions of the system the update makes sense for. * Add the name of the file to each version's category below. * Put this file and the update file on all of the servers. * * To make a new version of the system: Pick a name for it (no restrictions) * Put # and exactly that name on a new line at the end of this file. * During the release process, fill in exactly that name in the dialog box. * Put this file on the server." "When two sets of updates need to use the same directory, one of them has a * in its serverUrls description. When that is true, the first word of the description is put on the front of 'updates.list', and that is the index file used." "UpdateStreamDownloader readServerUpdatesThrough: 3922 saveLocally: true updateImage: true" | failed loaded str res servers triple tryAgain indexPrefix | UpdateStreamDownloader chooseUpdateList ifFalse: [^ self]. "ask the user which kind of updates" servers := UpdateStreamDownloader serverUrls copy. indexPrefix := (UpdateStreamDownloader updateUrlLists first first includes: $*) ifTrue: [(UpdateStreamDownloader updateUrlLists first first findTokens: ' ') first] "special for internal updates" ifFalse: ['']. "normal" [servers isEmpty] whileFalse: [ triple := self readServer: servers special: indexPrefix updatesThrough: maxNumber saveLocally: saveLocally updateImage: updateImage. "report to user" failed := triple first. loaded := triple second. tryAgain := false. failed ifNil: ["is OK" loaded = 0 ifTrue: ["found no updates" servers size > 1 ifTrue: ["not the last server" res := UIManager default chooseFrom: #('Stop looking' 'Try next server') title: 'No new updates on the server ', servers first, ' Would you like to try the next server? (Normally, all servers are identical, but sometimes a server won''t let us store new files, and gets out of date.)' . res = 2 ifFalse: [^ self] ifTrue: [servers := servers allButFirst. "try the next server" tryAgain := true]]]]. tryAgain ifFalse: [ str := loaded printString ,' new update file(s) processed.'. ^ self inform: str]. ].! ----- Method: UpdateStreamDownloader class>>retrieveUrls:ontoQueue:withWaitSema: (in category 'fetching updates') ----- retrieveUrls: urls ontoQueue: queue withWaitSema: waitSema "download the given list of URLs. The queue will be loaded alternately with url's and with the retrieved contents. If a download fails, the contents will be #failed. If all goes well, a special pair with an empty URL and the contents #finished will be put on the queue. waitSema is waited on every time before a new document is downloaded; this keeps the downloader from getting too far ahead of the main process" "kill the existing downloader if there is one" | updateCounter | UpdateDownloader ifNotNil: [UpdateDownloader terminate]. updateCounter := 0. "fork a new downloading process" UpdateDownloader := [ 'Downloading updates' displayProgressFrom: 0 to: urls size during: [:bar | urls do: [:url | | front canPeek doc | waitSema wait. queue nextPut: url. doc := HTTPClient httpGet: url. doc isString ifTrue: [queue nextPut: #failed. UpdateDownloader := nil. Processor activeProcess terminate] ifFalse: [canPeek := 120 min: doc size. front := doc next: canPeek. doc skip: -1 * canPeek. (front beginsWith: '<!!DOCTYPE') ifTrue: [ (front includesSubString: 'Not Found') ifTrue: [ queue nextPut: #failed. UpdateDownloader := nil. Processor activeProcess terminate]]]. UpdateDownloader ifNotNil: [queue nextPut: doc. updateCounter := updateCounter + 1. bar value: updateCounter]]]. queue nextPut: ''. queue nextPut: #finished. UpdateDownloader := nil] newProcess. UpdateDownloader priority: Processor userInterruptPriority. "start the process running" UpdateDownloader resume! ----- Method: UpdateStreamDownloader class>>saveUpdate:onFile: (in category 'fetching updates') ----- saveUpdate: doc onFile: fileName "Save the update on a local file. With or without the update number on the front, depending on the preference #updateRemoveSequenceNum" | file fName pos updateDirectory | (FileDirectory default directoryNames includes: 'updates') ifFalse: [FileDirectory default createDirectory: 'updates']. updateDirectory := FileDirectory default directoryNamed: 'updates'. fName := fileName. self updateRemoveSequenceNum ifTrue: [pos := fName findFirst: [:c | c isDigit not]. fName := fName copyFrom: pos to: fName size]. doc reset; ascii. (updateDirectory fileExists: fName) ifFalse: [file := updateDirectory newFileNamed: fName. file nextPutAll: doc contents. file close]. ! ----- Method: UpdateStreamDownloader class>>serverUrls (in category 'server urls') ----- serverUrls "Return the current list of server URLs. For code updates. Format of UpdateUrlLists is #( ('squeak updates' ('url1' 'url2')) ('some other updates' ('url3' 'url4')))" | list | list := UpdateUrlLists first last. "If there is a dead server, return a copy with that server last" Socket deadServer ifNotNil: [ list clone withIndexDo: [:aName :ind | (aName beginsWith: Socket deadServer) ifTrue: [ list := list asOrderedCollection. "and it's a copy" list removeAt: ind. list addLast: aName]] ]. ^ list asArray! ----- Method: UpdateStreamDownloader class>>setUpdateServer: (in category 'fetching updates') ----- setUpdateServer: groupName "UpdateStreamDownloader setUpdateServer: 'Squeakland' " | entry index | entry := UpdateUrlLists detect: [:each | each first = groupName] ifNone: [^self]. index := UpdateUrlLists indexOf: entry. UpdateUrlLists removeAt: index. UpdateUrlLists addFirst: entry! ----- Method: UpdateStreamDownloader class>>summariesForUpdates:through: (in category 'fetching updates') ----- summariesForUpdates: startNumber through: stopNumber "Answer the concatenation of summary strings for updates numbered in the given range" ^ String streamContents: [:aStream | ((ChangeSet changeSetsNamedSuchThat: [:aName | aName first isDigit and: [aName initialIntegerOrNil >= startNumber and: [aName initialIntegerOrNil <= stopNumber]]]) asSortedCollection: [:a :b | a name < b name]) do: [:aChangeSet | aStream cr; nextPutAll: aChangeSet summaryString]] "UpdateStreamDownloader summariesForUpdates: 4899 through: 4903" ! ----- Method: UpdateStreamDownloader class>>updateComment (in category 'fetching updates') ----- updateComment "The following used to be at the beginning of the update file. Now it is here to simplify parsing the file... * To add a new update: Name it starting with a new four-digit code. * Do not use %, /, *, space, or more than one period in the name of an update file. * The update name does not need to have any relation to the version name. * Figure out which versions of the system the update makes sense for. * Add the name of the file to each version's category below. * Put this file and the update file on all of the servers. * * To make a new version of the system: Pick a name for it (no restrictions) * Put # and exactly that name on a new line at the end of this file. * During the release process, fill in exactly that name in the dialog box. * Put a copy of updates.list on the server. * * Special file with a different name for Disney Internal Updates. * No need to move or rename files to release them to external updates. "! ----- Method: UpdateStreamDownloader class>>updateFromServer (in category 'fetching updates') ----- updateFromServer "Update the image by loading all pending updates from the server. Also save local copies of the update files if the #updateSavesFile preference is set to true" self readServerUpdatesSaveLocally: self updateSavesFile updateImage: true! ----- Method: UpdateStreamDownloader class>>updateFromServerThroughUpdateNumber: (in category 'fetching updates') ----- updateFromServerThroughUpdateNumber: aNumber "Update the image by loading all pending updates from the server. Also save local copies of the update files if the #updateSavesFile preference is set to true" self readServerUpdatesThrough: aNumber saveLocally: self updateSavesFile updateImage: true! ----- Method: UpdateStreamDownloader class>>updateRemoveSequenceNum (in category 'preferences') ----- updateRemoveSequenceNum ^false! ----- Method: UpdateStreamDownloader class>>updateSavesFile (in category 'preferences') ----- updateSavesFile <preference: 'Update saves files' category: 'updates' description: 'If true, then when an update is loaded from the server, a copy of it will automatically be saved on a local file as well.' type: #Boolean> ^UpdateSavesFile ifNil: [ false ]! ----- Method: UpdateStreamDownloader class>>updateSavesFile: (in category 'preferences') ----- updateSavesFile: aBoolean UpdateSavesFile := aBoolean! ----- Method: UpdateStreamDownloader class>>updateUrlLists (in category 'server urls') ----- updateUrlLists UpdateUrlLists ifNil: [UpdateUrlLists := OrderedCollection new]. ^ UpdateUrlLists! ----- Method: UpdateStreamDownloader class>>writeList:toStream: (in category 'fetching updates') ----- writeList: listContents toStream: strm "Write a parsed updates.list out as text. This is the inverse of parseListContents:" strm reset. listContents do: [:pair | | version fileNames | version := pair first. fileNames := pair last. strm nextPut: $#; nextPutAll: version; cr. fileNames do: [:fileName | strm nextPutAll: fileName; cr]]. strm close! ----- Method: UpdateStreamDownloader class>>zapUpdateDownloader (in category 'fetching updates') ----- zapUpdateDownloader UpdateDownloader ifNotNil: [UpdateDownloader terminate]. UpdateDownloader := nil.! ----- Method: AutoStart class>>checkForUpdates (in category '*UpdateStream') ----- checkForUpdates | availableUpdate updateServer | World ifNotNil: [ World install. ActiveHand position: 100 @ 100 ]. HTTPClient isRunningInBrowser ifFalse: [ ^ self processUpdates ]. availableUpdate := (Smalltalk namedArguments at: 'UPDATE' ifAbsent: [ '' ]) asInteger. availableUpdate ifNil: [ ^ false ]. updateServer := Smalltalk namedArguments at: 'UPDATESERVER' ifAbsent: [ Smalltalk namedArguments at: 'UPDATE_SERVER' ifAbsent: [ 'Squeakland' ] ]. UpdateStreamDownloader default setUpdateServer: updateServer. ^ SystemVersion checkAndApplyUpdates: availableUpdate! ----- Method: FileList>>putUpdate: (in category '*UpdateStream') ----- putUpdate: fullFileName "Put this file out as an Update on the servers." | names choice | self canDiscardEdits ifFalse: [^ self changed: #flash]. names := ServerDirectory groupNames asSortedArray. choice := UIManager default chooseFrom: names values: names. choice == nil ifTrue: [^ self]. (ServerDirectory serverInGroupNamed: choice) putUpdate: (directory oldFileNamed: fullFileName). self volumeListIndex: volListIndex. ! ----- Method: FileList>>serviceBroadcastUpdate (in category '*UpdateStream') ----- serviceBroadcastUpdate "Answer a service for broadcasting a file as an update" ^ SimpleServiceEntry provider: self label: 'broadcast as update' selector: #putUpdate: description: 'broadcast file as update' buttonLabel: 'broadcast'! ----- Method: FilePackage class>>conflictsWithUpdatedMethods: (in category '*UpdateStream-instance creation') ----- conflictsWithUpdatedMethods: fullName | conflicts changeList | conflicts := (self fromFileNamed: fullName) conflictsWithUpdatedMethods. conflicts isEmpty ifTrue: [^ self]. changeList := ChangeList new. changeList changes: conflicts file: (FileDirectory default readOnlyFileNamed: fullName) close. ChangeList open: changeList name: 'Conflicts for ', (FileDirectory localNameFor: fullName) multiSelect: true.! ----- Method: FilePackage class>>fileReaderServicesForFile:suffix: (in category '*UpdateStream-reader service') ----- fileReaderServicesForFile: fullName suffix: suffix ^(suffix = 'st') | (suffix = 'cs') | (suffix = '*') ifTrue: [self services] ifFalse: [#()]! ----- Method: FilePackage class>>serviceConflictsWithUpdatedMethods (in category '*UpdateStream-reader service') ----- serviceConflictsWithUpdatedMethods ^ SimpleServiceEntry provider: self label: 'conflicts with updated methods' selector: #conflictsWithUpdatedMethods: description: 'check for conflicts with more recently updated methods in the image, showing the conflicts in a transcript window' buttonLabel: 'conflicts'! ----- Method: FilePackage class>>services (in category '*UpdateStream-reader service') ----- services ^ Array with: self serviceConflictsWithUpdatedMethods! ----- Method: FilePackage>>checkForMoreRecentUpdateThanChangeSet:pseudoClass:selector: (in category '*UpdateStream-conflict checker') ----- checkForMoreRecentUpdateThanChangeSet: updateNumberChangeSet pseudoClass: pseudoClass selector: selector "Returns the source code for a conflict if a conflict is found, otherwise returns nil." | classOrMeta allChangeSets moreRecentChangeSets conflictingChangeSets changeRecordSource classAndMethodPrintString | classAndMethodPrintString := pseudoClass name, (pseudoClass hasMetaclass ifTrue: [' class'] ifFalse: ['']), '>>', selector asString. changeRecordSource := pseudoClass sourceCode at: selector. changeRecordSource isText ifTrue: [changeRecordSource := Text fromString: 'method: ', classAndMethodPrintString, ' was removed'] ifFalse: [changeRecordSource stamp isEmptyOrNil ifTrue: [self notify: 'Warning: ', classAndMethodPrintString, ' in ', self packageName, ' has no timestamp/initials!!']]. pseudoClass exists ifFalse: [(self classes at: pseudoClass name) hasDefinition ifTrue: [^ nil "a method was added for a newly defined class; not a conflict"] ifFalse: [self class logCr; log: 'CONFLICT found for ', classAndMethodPrintString, '... class ', pseudoClass name asString, ' does not exist in the image and is not defined in the file'. ^ changeRecordSource]]. classOrMeta := pseudoClass realClass. "Only printout the replacing methods here, but we still check for removed methods too in the rest of this method." (self class verboseConflicts and: [classOrMeta includesSelector: selector]) ifTrue: [self class logCr; log: '...checking ', classOrMeta asString, '>>', selector asString]. allChangeSets := ChangesOrganizer allChangeSets. moreRecentChangeSets := allChangeSets copyFrom: (allChangeSets indexOf: updateNumberChangeSet) to: (allChangeSets size). conflictingChangeSets := (moreRecentChangeSets select: [:cs | (cs atSelector: selector class: classOrMeta) ~~ #none]). conflictingChangeSets isEmpty ifTrue: [^ nil]. self class logCr; log: 'CONFLICT found for ', classAndMethodPrintString, (' with newer changeset' asPluralBasedOn: conflictingChangeSets). conflictingChangeSets do: [:cs | self class log: ' ', cs name]. ^ changeRecordSource ! ----- Method: FilePackage>>conflictsWithUpdatedMethods (in category '*UpdateStream-conflict checker') ----- conflictsWithUpdatedMethods "Check this package for conflicts with methods in the image which are in newer updates." | localFileName stream updateNumberString updateNumber imageUpdateNumber updateNumberChangeSet conflicts fileStream | localFileName := FileDirectory localNameFor: fullName. stream := ReadStream on: sourceSystem. stream upToAll: 'latest update: #'. updateNumberString := stream upTo: $]. stream close. fileStream := FileStream readOnlyFileNamed: fullName. (fileStream contentsOfEntireFile includes: Character linefeed) ifTrue: [self notifyWithLabel: 'The changeset file ', localFileName, ' contains linefeeds. Proceed if... you know that this is okay (e.g. the file contains raw binary data).']. fileStream close. updateNumberString isEmpty ifFalse: "remove prepended junk, if any" [updateNumberString := (updateNumberString findTokens: Character space) last]. updateNumberString asInteger ifNil: [(self confirm: 'Error: ', localFileName, ' has no valid Latest Update number in its header. Do you want to enter an update number for this file?') ifFalse: [^ self] ifTrue: [updateNumberString := UIManager default request: 'Please enter the estimated update number (e.g. 4332).']]. updateNumberString asInteger ifNil: [self inform: 'Conflict check cancelled.'. ^ self]. updateNumber := updateNumberString asInteger. imageUpdateNumber := SystemVersion current highestUpdate. updateNumber > imageUpdateNumber ifTrue: [(self confirm: 'Warning: The update number for this file (#', updateNumberString, ') is greater than the highest update number for this image (#', imageUpdateNumber asString, '). This probably means you need to update your image. Should we proceed anyway as if the file update number is #', imageUpdateNumber asString, '?') ifTrue: [updateNumber := imageUpdateNumber. updateNumberString := imageUpdateNumber asString] ifFalse: [^ self]]. updateNumberChangeSet := self findUpdateChangeSetMatching: updateNumber. updateNumberChangeSet ifNil: [^ self]. Smalltalk isMorphic ifTrue: [self currentWorld findATranscript: self currentEvent]. self class logCr; logCr; log: 'Checking ', localFileName, ' (#', updateNumberString, ') for method conflicts with changesets after ', updateNumberChangeSet name, ' ...'. conflicts := OrderedCollection new. self classes do: [:pseudoClass | (Array with: pseudoClass with: pseudoClass metaClass) do: [:classOrMeta | classOrMeta selectorsDo: [:selector | | conflict | conflict := self checkForMoreRecentUpdateThanChangeSet: updateNumberChangeSet pseudoClass: classOrMeta selector: selector. conflict ifNotNil: [conflicts add: conflict]. ]. ]. ]. self class logCr; log: conflicts size asString, (' conflict' asPluralBasedOn: conflicts), ' found.'; logCr. self class closeLog. ^ conflicts! ----- Method: FilePackage>>findUpdateChangeSetMatching: (in category '*UpdateStream-conflict checker') ----- findUpdateChangeSetMatching: updateNumber "Find update-changeset beginning with updateNumber, or reasonably close." "This is to account for the fact that many changeset files are output from final releases, but may be tested for conflicts in a following alpha image, which will often not include that particular update-changeset from the final release but will contain ones near it. For example, if the file updateNumber is 5180 (from 3.5 final), but the image has no update-changeset beginning with 5180 because it's a 3.6alpha image (which starts at 5181), it will try up to 5190 and down to 5170 for a close match." | updateNumberChangeSet updateNumberToTry | updateNumberToTry := updateNumber. updateNumberChangeSet := nil. [updateNumberChangeSet isNil and: [updateNumberToTry notNil]] whileTrue: [updateNumberChangeSet := ChangesOrganizer allChangeSets detect: [:cs | (cs name beginsWith: updateNumberToTry asString) and: [(cs name at: (updateNumberToTry asString size + 1)) isDigit not]] ifNone: [nil]. updateNumberToTry >= updateNumber ifTrue: [updateNumberToTry < (updateNumber + 10) ifTrue: [updateNumberToTry := updateNumberToTry + 1] ifFalse: [updateNumberToTry := updateNumber]]. updateNumberToTry <= updateNumber ifTrue: [updateNumberToTry > (updateNumber - 10) ifTrue: [updateNumberToTry := updateNumberToTry - 1] ifFalse: [updateNumberToTry := nil "we're done trying"]]. ]. updateNumberChangeSet ifNil: [(self confirm: 'Warning: No changeset beginning with ', updateNumber asString, ' (within +/- 10) was found in the image. You must have changesets going back this far in your image in order to accurately check for conflicts. Proceed anyway?') ifTrue: [updateNumberChangeSet := ChangesOrganizer allChangeSets first]]. ^ updateNumberChangeSet! ----- Method: MCConfigurationBrowser>>post (in category '*UpdateStream') ----- post "Take the current configuration and post an update" | name update managers names choice | (self checkRepositories and: [self checkDependencies]) ifFalse: [^self]. name := UIManager default request: 'Update name (.cs) will be appended):' initialAnswer: self configuration suggestedNameOfNextVersion. name isEmpty ifTrue:[^self]. self configuration name: name. update := MCPseudoFileStream on: (String new: 100). update localName: name, '.cs'. update nextPutAll: '"Change Set: ', name. update cr; nextPutAll: 'Date: ', Date today printString. update cr; nextPutAll: 'Author: Posted by Monticello'. update cr; cr; nextPutAll: 'This is a configuration map created by Monticello."'. update cr; cr; nextPutAll: '(MCConfiguration fromArray: #'. self configuration fileOutOn: update. update nextPutAll: ') upgrade.'. update position: 0. managers := Smalltalk at: #UpdateManager ifPresent:[:mgr| mgr allRegisteredManagers]. managers ifNil:[managers := #()]. managers size > 0 ifTrue:[ | servers index | servers := ServerDirectory groupNames asSortedArray. names := (managers collect:[:each| each packageVersion]), servers. index := UIManager default chooseFrom: names lines: {managers size}. index = 0 ifTrue:[^self]. index <= managers size ifTrue:[ | mgr | mgr := managers at: index. ^mgr publishUpdate: update. ]. choice := names at: index. ] ifFalse:[ names := ServerDirectory groupNames asSortedArray. choice := UIManager default chooseFrom: names values: names. choice == nil ifTrue: [^ self]. ]. (ServerDirectory serverInGroupNamed: choice) putUpdate: update.! ----- Method: SystemVersion class>>checkAndApplyUpdates: (in category '*UpdateStream') ----- checkAndApplyUpdates: availableUpdate "SystemVersion checkAndApplyUpdates: nil" ^(availableUpdate isNil or: [availableUpdate > SystemVersion current highestUpdate]) ifTrue: [ (self confirm: 'There are updates available. Do you want to install them now?') ifFalse: [^false]. UpdateStreamDownloader default readServerUpdatesThrough: availableUpdate saveLocally: false updateImage: true. Smalltalk snapshot: true andQuit: false. true] ifFalse: [false]!

1 0

Squeak 4.6: Services-Base-mt.55.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of Services-Base to project Squeak 4.6: http://source.squeak.org/squeak46/Services-Base-mt.55.mcz ==================== Summary ==================== Name: Services-Base-mt.55 Author: mt Time: 12 April 2015, 9:07:10.492 pm UUID: 3b374e3f-27ec-ff4f-9af9-89da39d9d38b Ancestors: Services-Base-topa.54 MVC compatibility. ==================== Snapshot ==================== SystemOrganization addCategory: #'Services-Base'! SystemOrganization addCategory: #'Services-Base-Providers'! SystemOrganization addCategory: #'Services-Base-Requestors'! SystemOrganization addCategory: #'Services-Base-GUI'! Preferences subclass: #ServicePreferences instanceVariableNames: '' classVariableNames: 'ServiceDictionaryOfPreferences' poolDictionaries: '' category: 'Services-Base-GUI'! !ServicePreferences commentStamp: 'rr 7/10/2006 15:36' prior: 0! I store the preferences related to the servicse framework. The preferences are editable via the Services Browser, based on Hernan Tylim's Preference Browser. The main preference categories for services are: -- keyboard shortcuts -- : several text preferences, one per keyboard shortcuts. To edit them, enter a service identifier (equal to the method name under which it is defined in its ServiceProvider), and accept with alt-s or enter -- menu contents -- : All the service categories in the image have a text preference under here. To edit it, enter the services identifiers you wish to put in this category, separating them with a single space character. The order is important: it defines the order of the items in menus. -- settings -- : general boolean preferences. Then there is a preference category for each provider in the image. Under each, you will find: A boolean preference for each service in the image. If it is false, the service will not appear in menus. The text preference for each service category defined by the service provider. This is the same as the one appearing in the menu contents preference category.! ----- Method: ServicePreferences class>>compileAccessMethodForPreference: (in category 'accessing') ----- compileAccessMethodForPreference: aPreference "do nothing"! ----- Method: ServicePreferences class>>dictionaryOfPreferences (in category 'accessing') ----- dictionaryOfPreferences ServiceDictionaryOfPreferences ifNil: [ServiceDictionaryOfPreferences := IdentityDictionary new]. ^ ServiceDictionaryOfPreferences ! ----- Method: ServicePreferences class>>dictionaryOfPreferences: (in category 'accessing') ----- dictionaryOfPreferences: aDictionary ServiceDictionaryOfPreferences := aDictionary! ----- Method: ServicePreferences class>>replayPreferences: (in category 'replaying') ----- replayPreferences: preferences | s | s := SortedCollection new sortBlock: [:a :b | a last < b last]. s addAll: preferences; reSort. s do: [:e | | v | v := self valueOfPreference: e first ifAbsent: ''. self setPreference: e first toValue: (v ifEmpty: [''] ifNotEmpty: [v , ' ']) , e second]! ----- Method: ServicePreferences class>>wipe (in category 'accessing') ----- wipe self dictionaryOfPreferences: nil! ----- Method: PasteUpMorph>>openWorldMenu (in category '*services-base') ----- openWorldMenu | menu | menu := (TheWorldMenu new adaptToWorld: self) buildWorldMenu. menu addTitle: Preferences desktopMenuTitle translated. menu openInHand! ----- Method: PasteUpMorph>>requestor (in category '*services-base') ----- requestor "returns the focused window's requestor" ^ Requestor default! ----- Method: PasteUpMorph>>topRequestor (in category '*services-base') ----- topRequestor "returns the focused window's requestor" ^ SystemWindow topWindow requestor! ----- Method: PasteUpMorph>>worldMenu (in category '*services-base') ----- worldMenu ^ TheWorldMenu new adaptToWorld: self! ----- Method: Model>>requestor (in category '*services-base') ----- requestor ^ Requestor default! ----- Method: StringHolder>>codePaneMenuServices: (in category '*services-base') ----- codePaneMenuServices: aMenu <codePaneMenu> <menuPriority: 150> ServiceGui browser: self codePaneMenu: aMenu. ^ Preferences useOnlyServicesInMenu ifTrue: [nil] ifFalse: [aMenu]! ----- Method: StringHolder>>requestor (in category '*services-base') ----- requestor ^ (TextRequestor new) model: self; yourself! ----- Method: StringHolder>>selectedInterval (in category '*services-base') ----- selectedInterval ^self codeTextMorph selectionInterval! ----- Method: Collection>>chooseOne: (in category '*services-base') ----- chooseOne: caption "pops up a menu asking for one of the elements in the collection. If none is chosen, raises a ServiceCancelled notification" | m | m := MenuMorph entitled: caption. self do: [:ea | m add: ea target: [:n | ^ n] selector: #value: argument: ea]. m invokeModal. ServiceCancelled signal! ----- Method: PreferenceBrowserMorph class>>updateBrowsers (in category '*services-base') ----- updateBrowsers (self allInstances select: [:e | e visible]) do: [:each | (each findDeepSubmorphThat:[:m | m isKindOf:PluggableListMorph] ifAbsent:[^ self]) verifyContents].! PreferenceBrowserMorph subclass: #ServiceBrowserMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Services-Base-GUI'! !ServiceBrowserMorph commentStamp: 'rr 7/10/2006 15:28' prior: 0! I subclass the PreferenceBrowserMorph to adapt the interface to services. So far the changes are minimal.! ----- Method: ServiceBrowserMorph>>newButtonRow (in category 'as yet unclassified') ----- newButtonRow ^BorderedMorph new color: Color transparent; cellInset: 2; layoutInset: 2; layoutPolicy: TableLayout new; listDirection: #leftToRight; listCentering: #topLeft; cellPositioning: #topLeft; on: #mouseEnter send: #paneTransition: to: self; on: #mouseLeave send: #paneTransition: to: self; "addMorphBack: self defaultButton; addMorphBack: self newSeparator; addMorphBack: self saveButton; addMorphBack: self loadButton; addMorphBack: self newSeparator; addMorphBack: self saveToDiskButton; addMorphBack: self loadFromDiskButton; addMorphBack: self newSeparator; addMorphBack: self newTransparentFiller; addMorphBack: self helpButton;" yourself.! ----- Method: SystemWindow class>>topWindow (in category '*services-base') ----- topWindow ^ TopWindow! ----- Method: SystemWindow>>requestor (in category '*services-base') ----- requestor ^[model requestor] on: Error do: [Transcript show: 'no requestor for : ', model class name. Requestor default] ! ----- Method: SystemWindow>>topWindow (in category '*services-base') ----- topWindow ^ TopWindow! ----- Method: BlockContext>>valueWithRequestor: (in category '*services-base') ----- valueWithRequestor: aRequestor "To do later: make the fillInTheBlank display more informative captions. Include the description of the service, and maybe record steps" ^ self numArgs isZero ifTrue: [self value] ifFalse: [self value: aRequestor]! ----- Method: Association>>serviceUpdate (in category '*services-base-preferences') ----- serviceUpdate self key service perform: self value! ----- Method: PreferenceBrowser class>>openForServices (in category '*services-base') ----- openForServices "PreferenceBrowser openForServices" | browser | browser := self new. browser initializeForServices. (ServiceBrowserMorph withModel: browser) openInWorld. ^browser. ! ----- Method: PreferenceBrowser>>initializeForServices (in category '*services-base') ----- initializeForServices preferences := ServicePreferences. title := 'Services Browser'! ----- Method: MessageSet>>browseReference: (in category '*services-base') ----- browseReference: ref self okToChange ifTrue: [ self initializeMessageList: (OrderedCollection with: ref). self changed: #messageList. self messageListIndex: 1. ] ! ----- Method: MessageSet>>selectReference: (in category '*services-base') ----- selectReference: ref self okToChange ifTrue: [self messageListIndex: (self messageList indexOf: ref)]! ----- Method: String>>service (in category '*services-base') ----- service ^ self serviceOrNil ifNil: [ServiceCategory new id: self asSymbol]! ----- Method: String>>serviceOrNil (in category '*services-base') ----- serviceOrNil ^ ServiceRegistry current serviceWithId: self asSymbol! Object subclass: #BasicRequestor instanceVariableNames: 'caption answer' classVariableNames: '' poolDictionaries: '' category: 'Services-Base'! !BasicRequestor commentStamp: 'rr 7/10/2006 14:44' prior: 0! This class is the root of the Requestor hierarchy. Requestors are interfaces between services and the system. ServiceActions are given an instance of a Requestor, and they ask it for the data they need. The requestor is determined by the model of the application. A class used as a model can implement the #requestor message to return the most suited requestor. A requestor knows how to query its model and the user if needed. Requestor are defined in hierarchies so that the protocol they rely on (methods starting with 'get') can be easily reused.! ----- Method: BasicRequestor>>caption: (in category 'generic requests') ----- caption: aString caption := aString! ----- Method: BasicRequestor>>get: (in category 'executing') ----- get: aString self caption: aString. ^ self getSymbol! ----- Method: BasicRequestor>>getString (in category 'generic requests') ----- getString | result | result := UIManager default request:caption initialAnswer:answer contents. self newCaption. result isEmpty |result isNil ifTrue:[ServiceCancelled signal]. ^ result! ----- Method: BasicRequestor>>getStringCollection (in category 'generic requests') ----- getStringCollection caption := caption, Character cr asString, 'Separate items with space'. ^ (self getString findTokens: ' ') collect: [:each | each copyWithoutAll: ' ' ]! ----- Method: BasicRequestor>>getSymbol (in category 'generic requests') ----- getSymbol ^ self getString asSymbol! ----- Method: BasicRequestor>>getSymbolCollection (in category 'generic requests') ----- getSymbolCollection ^[self getStringCollection collect: [:each | each asSymbol]] on: ServiceCancelled do: [#()]! ----- Method: BasicRequestor>>initialize (in category 'initialize-release') ----- initialize self newCaption! ----- Method: BasicRequestor>>newCaption (in category 'generic requests') ----- newCaption caption := 'Enter text'. answer := String new writeStream.! BasicRequestor subclass: #Requestor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Services-Base-Requestors'! !Requestor commentStamp: 'rr 7/10/2006 15:19' prior: 0! I am an implementation of BasicRequestor with some requests already implemented.! ----- Method: Requestor class>>default (in category 'as yet unclassified') ----- default "returns a default requestor" ^ self new! ----- Method: Requestor>>getClass (in category 'requests') ----- getClass ^Smalltalk at: self getSymbol! ----- Method: Requestor>>getClassCollection (in category 'requests') ----- getClassCollection ^ self getSymbolCollection collect: [:className | Smalltalk at: className]! ----- Method: Requestor>>getMethodBody (in category 'requests') ----- getMethodBody | m | m := FillInTheBlankMorph new. m setQuery: 'Please enter the full body of the method you want to define' initialAnswer: self class sourceCodeTemplate answerExtent: 500@250 acceptOnCR: false. World addMorph: m centeredNear: World activeHand position. ^ m getUserResponse.! ----- Method: Requestor>>getSelection (in category 'requests') ----- getSelection "Sorry to feedle with fillInTheBlankMorph innards, but I had to" | text m | text := (MethodReference class: self getClass selector: self getSelector) sourceCode. m := FillInTheBlankMorph new. m setQuery: 'Highlight a part of the source code, and accept' initialAnswer: text answerExtent: 500@250 acceptOnCR: true. World addMorph: m centeredNear: World activeHand position. m getUserResponse. ^ m selection! ----- Method: Requestor>>getSelector (in category 'services requests') ----- getSelector ^ self caption: 'enter selector'; getSymbol! Requestor subclass: #TextRequestor instanceVariableNames: 'model' classVariableNames: '' poolDictionaries: '' category: 'Services-Base-Requestors'! !TextRequestor commentStamp: 'rr 7/10/2006 15:20' prior: 0! A requestor for text areas, able for example to fetch the current selected text.! TextRequestor subclass: #BrowserRequestor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Services-Base-Requestors'! !BrowserRequestor commentStamp: 'rr 7/10/2006 15:24' prior: 0! I am a requestor specialized to fetch information in a Browser. I can ask a browser its selected class and selected method for example. If the RB is installed too, I can also fetch ast nodes in the browser's selected method. I am the default requestor for CodeHolder and it's subclasses. To be integrated with services, alternative browsers, such as the OmniBrowser and Whisker should define a specialized requestor subclassing this one. A few core messages would need to be redefined, such as getClass, getMessage ... to be adapted to the browser's data structures. Only a few of them have to be overridden, the majority of the requests rely on a few base ones.! ----- Method: BrowserRequestor>>browser: (in category 'initialize-release') ----- browser: b self model: b! ----- Method: BrowserRequestor>>getBrowser (in category 'requests') ----- getBrowser ^ self getModel! ----- Method: BrowserRequestor>>getClass (in category 'requests') ----- getClass ^ self getBrowser selectedClassOrMetaClass! ----- Method: BrowserRequestor>>getInitializingExpressionForTheNewParameter (in category 'requests') ----- getInitializingExpressionForTheNewParameter ^ UIManager default request: 'enter default parameter code' initialAnswer: '42'! ----- Method: BrowserRequestor>>getNewSelectorName (in category 'requests') ----- getNewSelectorName ^ UIManager default request: 'enter the new selector name' initialAnswer: self getSelector! ----- Method: BrowserRequestor>>getNewVariableName (in category 'requests') ----- getNewVariableName ^ UIManager default request: 'Enter the new variable name' translated initialAnswer: 'foo'! ----- Method: BrowserRequestor>>getPackage (in category 'requests') ----- getPackage self getSelector ifNil: [ ^ PackageInfo named:( self getClass ifNil: [self getSystemCategory] ifNotNil: [:c | c category copyUpTo: $-])]. ^ PackageOrganizer default packageOfMethod: (MethodReference class: self getClass selector: self getSelector) ifNone: [PackageInfo named: (self getClass category copyUpTo: $-)] ! ----- Method: BrowserRequestor>>getPackageForCategory (in category 'requests') ----- getPackageForCategory "answers a packageinfo for the current class category" ^ PackageInfo named: self getClass category! ----- Method: BrowserRequestor>>getPackageForCategoryName (in category 'requests') ----- getPackageForCategoryName "answers a packageinfo for the current class category" ^ self getPackageForCategory packageName! ----- Method: BrowserRequestor>>getPackageName (in category 'requests') ----- getPackageName ^ self getPackage packageName! ----- Method: BrowserRequestor>>getPackageProvider (in category 'requests') ----- getPackageProvider | provs classes | provs := ServiceProvider registeredProviders. classes := self getPackage classes. ^ classes detect: [:e | provs includes: e] ifNone: [ServiceProvider newProviderFor: self getPackageName]! ----- Method: BrowserRequestor>>getSelection (in category 'requests') ----- getSelection self getBrowser selectedInterval ifEmpty: [^super getSelection]. ^ self getBrowser selectedInterval! ----- Method: BrowserRequestor>>getSelector (in category 'requests') ----- getSelector | s | s := self getBrowser selectedMessageName. ^ s ifNil: [super getSelector] ifNotNil: [s]! ----- Method: BrowserRequestor>>getSelectorCollection (in category 'requests') ----- getSelectorCollection self caption: 'enter selector list'. ^ self getSymbolCollection ! ----- Method: BrowserRequestor>>getSelectorName (in category 'requests') ----- getSelectorName ^ self getBrowser selectedMessageName! ----- Method: BrowserRequestor>>getSystemCategory (in category 'requests') ----- getSystemCategory ^ self getBrowser selectedSystemCategory! ----- Method: TextRequestor>>getCurrentText (in category 'request') ----- getCurrentText "returns the unnacepted text in the text morph" ^ self getModel codeTextMorph text! ----- Method: TextRequestor>>getModel (in category 'request') ----- getModel ^ model first! ----- Method: TextRequestor>>model: (in category 'accessing') ----- model: aModel model := WeakArray with: aModel! ----- Method: Object>>requestor (in category '*services-base') ----- requestor "returns the focused window's requestor" "SystemWindow focusedWindow ifNotNilDo: [:w | ^ w requestor]." "triggers an infinite loop" ^ Requestor default! Object subclass: #ServiceAction instanceVariableNames: 'condition action requestor label shortLabel description id provider enabled' classVariableNames: '' poolDictionaries: '' category: 'Services-Base'! !ServiceAction commentStamp: 'rr 7/10/2006 14:58' prior: 0! ServiceAction are executable objects in various contexts. They can be displayed as buttons or menu items or bounded to keyboard shortcuts. ServiceActions are defined in methods in an instance of a ServiceProvider class (in the 'services' method category), using the following template: serviceIdentifierAndMethodName ^ ServiceAction text: 'Menu item text' button: 'Button text' description: 'Longer text that appears in help balloons' action: [:r | "Code block fetching data from the requestor instance, r, that is passed to the block"] or, alternatively: serviceIdentifierAndMethodName ^ ServiceAction text: 'Menu item text' button: 'Button text' description: 'Longer text that appears in help balloons' action: [:r | "Code block fetching data from the requestor instance, r, that is passed to the block"] condition: [:r | "second block returning true if the service can be used at the time being, false otherwise. Data can still be fetched from the requestor instance"] The method name in which the service is defined becomes its identifier. To build the hierarchy of services and to assign them to shortcuts, you will need to type this names in the relevant fields of the Services Browser. Services are arranged in a hierarchy. and bound to keyboard shortcuts using the ServicesBrowser. ! ----- Method: ServiceAction class>>id:text:button:description:action: (in category 'instance creation') ----- id: aSymbol text: aStringOrBlock button: buttonString description: aString action: aBlock ^ self id: aSymbol text: aStringOrBlock button: buttonString description: aString action: aBlock condition: [:r | true]! ----- Method: ServiceAction class>>id:text:button:description:action:condition: (in category 'instance creation') ----- id: aSymbol text: aStringOrBlock button: buttonString description: aString action: aBlock condition: cBlock ^ (self new) id: aSymbol; text: aStringOrBlock; buttonLabel: buttonString; description: aString; action: aBlock; condition: cBlock; yourself! ----- Method: ServiceAction class>>initialize (in category 'class initialization') ----- initialize #( (inlineServicesInMenu true 'Inline the services the squeak menus') (useOnlyServicesInMenu false 'Use only services and not regular menu items') (useServicesInBrowserButtonBar false 'Use a service-based button bar')) do: [:tr | Preferences addPreference: tr first categories: #(#services) default: tr second balloonHelp: tr third] ! ----- Method: ServiceAction class>>text:button:description:action: (in category 'instance creation') ----- text: aStringOrBlock button: buttonString description: aString action: aBlock "use when id can be automatically generated" ^ self id: nil text: aStringOrBlock button: buttonString description: aString action: aBlock condition: [:r | true]! ----- Method: ServiceAction class>>text:button:description:action:condition: (in category 'instance creation') ----- text: aStringOrBlock button: buttonString description: aString action: aBlock condition: cBlock "use when id can be generated" ^ self id: nil text: aStringOrBlock button: buttonString description: aString action: aBlock condition: cBlock! ----- Method: ServiceAction class>>text:description:action: (in category 'instance creation') ----- text: textString description: aString action: aBlock "use when id can be generated" ^ self id: nil text: textString button: textString description: aString action: aBlock! ----- Method: ServiceAction>>action: (in category 'accessing') ----- action: aBlock action := aBlock! ----- Method: ServiceAction>>addPreference:category:selector: (in category 'preferences') ----- addPreference: name category: cat selector: sel ServicePreferences addPreference: name categories: {cat asSymbol. self providerCategory} default: '' balloonHelp:self description projectLocal:false changeInformee: self id -> sel changeSelector: #serviceUpdate type: #String! ----- Method: ServiceAction>>buttonLabel (in category 'accessing') ----- buttonLabel ^ shortLabel ifNil: [self text] ifNotNil: [shortLabel ifEmpty: [self text] ifNotEmpty: [shortLabel]]! ----- Method: ServiceAction>>buttonLabel: (in category 'accessing') ----- buttonLabel: anObject shortLabel := anObject! ----- Method: ServiceAction>>categories (in category 'accessing') ----- categories ^ ServiceRegistry current categories select: [:e | e services includes: self]! ----- Method: ServiceAction>>condExecuteWith: (in category 'executing') ----- condExecuteWith: aRequestor self requestor: aRequestor. self executeCondition ifTrue: [self execute] ifFalse: [Beeper beep]! ----- Method: ServiceAction>>condition: (in category 'accessing') ----- condition: aBlock condition := aBlock! ----- Method: ServiceAction>>description (in category 'accessing') ----- description ^ description ifNil: [self text] ifNotNil: [description]! ----- Method: ServiceAction>>description: (in category 'accessing') ----- description: anObject description := anObject select: [:each | (each = Character cr) not] thenCollect: [:each | each = Character tab ifTrue: [Character space] ifFalse: [each]].! ----- Method: ServiceAction>>execute (in category 'executing') ----- execute ^ action clone valueWithRequestor: World topRequestor! ----- Method: ServiceAction>>executeCondition (in category 'executing') ----- executeCondition ^ [condition clone valueWithRequestor: World topRequestor] on: Error do: [false]! ----- Method: ServiceAction>>id (in category 'accessing') ----- id ^id! ----- Method: ServiceAction>>id: (in category 'accessing') ----- id: aSymbol id := aSymbol! ----- Method: ServiceAction>>initialize (in category 'initialize-release') ----- initialize self action: []. self condition: [true]. self text: 'no op'. self requestor: Requestor new. self id: #none. enabled := true! ----- Method: ServiceAction>>insertPreferences (in category 'preferences') ----- insertPreferences ServicePreferences addPreference: self id categories: (Array with: self providerCategory) default: true balloonHelp: self description projectLocal: false changeInformee: self id -> #updateEnable changeSelector: #serviceUpdate type: #Boolean! ----- Method: ServiceAction>>isCategory (in category 'testing') ----- isCategory ^ false! ----- Method: ServiceAction>>isEnabled (in category 'testing') ----- isEnabled ^ enabled! ----- Method: ServiceAction>>menuLabel (in category 'accessing') ----- menuLabel | l sh | l := self text. l size > 50 ifTrue: [l := (l first: 47), '...']. sh := self shortcut. sh := (sh isNil or: [sh isEmpty]) ifTrue: [''] ifFalse: [' (', sh, ')']. ^ l capitalized, sh! ----- Method: ServiceAction>>menuLabelNumbered: (in category 'accessing') ----- menuLabelNumbered: index | shorterLabel shortCut serviceNumberString | shorterLabel := self text. shorterLabel size > 50 ifTrue: [ shorterLabel := (shorterLabel first: 47) , '...' ]. shortCut := self shortcut. shortCut := (shortCut isNil or: [ shortCut isEmpty ]) ifTrue: [ String empty ] ifFalse: [ ' (' , shortCut , ')' ]. serviceNumberString := index isZero ifTrue: [ String empty ] ifFalse: [ index asString , '.' ]. ^ serviceNumberString , shorterLabel , shortCut! ----- Method: ServiceAction>>perform:orSendTo: (in category 'executing') ----- perform: selector orSendTo: otherTarget ^ self perform: selector! ----- Method: ServiceAction>>preferences (in category 'preferences') ----- preferences ^ {ServicePreferences preferenceAt: self shortcutPreference} select: [:e | e notNil]! ----- Method: ServiceAction>>printOn: (in category 'printing') ----- printOn: aStream super printOn: aStream. aStream space ; nextPutAll: id asString! ----- Method: ServiceAction>>provider (in category 'accessing') ----- provider ^ provider ifNil: [nil] ifNotNil: [provider new]! ----- Method: ServiceAction>>provider: (in category 'accessing') ----- provider: p provider := p! ----- Method: ServiceAction>>providerCategory (in category 'preferences') ----- providerCategory ^ provider name! ----- Method: ServiceAction>>requestor (in category 'accessing') ----- requestor ^requestor! ----- Method: ServiceAction>>requestor: (in category 'accessing') ----- requestor: anObject requestor := anObject! ----- Method: ServiceAction>>shortcut (in category 'preferences') ----- shortcut ^ ServicePreferences valueOfPreference: self shortcutPreference! ----- Method: ServiceAction>>shortcutPreference (in category 'preferences') ----- shortcutPreference ^ ('Shortcut for ', self id, ':') asSymbol! ----- Method: ServiceAction>>text (in category 'accessing') ----- text ^label isBlock ifTrue: [label value: requestor] ifFalse: [label]! ----- Method: ServiceAction>>text: (in category 'accessing') ----- text: aString label := aString! ----- Method: ServiceAction>>updateEnable (in category 'preferences') ----- updateEnable enabled := ServicePreferences valueOfPreference: self id ifAbsent: [true]! ----- Method: ServiceAction>>updateShortcut (in category 'updating') ----- updateShortcut (self systemNavigation allImplementorsOf: #processService:newShortcut:) do: [:ref | | cls | cls := ref actualClass. cls isMeta ifTrue: [cls soleInstance processService: self newShortcut: self shortcut]]. ServiceRegistry ifInteractiveDo: [self provider savePreferencesFor: self]! ServiceAction subclass: #ServiceCategory instanceVariableNames: 'services' classVariableNames: '' poolDictionaries: '' category: 'Services-Base'! !ServiceCategory commentStamp: 'rr 7/10/2006 15:06' prior: 0! I represent a category of services that can be added to a menu. I can be displayed as a menu or button bar containing my services. I am also a subclass of ServiceAction, so I can form a subcategory of another service category. Like services, I am created in methods of a ServiceProvider, in the 'services' method protocol. The template to create a service category is the following: methodNameAndServiceCategoryId ^ ServiceCategory text: 'Menu text' button: 'Button text' description: 'Longer descriptive text appearing in help balloons' To put services in a service category, you have to use the Service Browser, located in the word menu, under the 'Preferences and Services' menu item. In it, you can look up for the name of your category, and enter service identifiers as children of the category in the associatedd text field, separating them with spaces.! ----- Method: ServiceCategory class>>text:button:description: (in category 'instance creation') ----- text: aStringOrBlock button: buttonString description: aString "use when id can be generated" ^ self id: nil text: aStringOrBlock button: buttonString description: aString action: [] ! ----- Method: ServiceCategory>>childrenPreferences (in category 'preferences') ----- childrenPreferences ^ ('Items in ', self id, ':') asSymbol! ----- Method: ServiceCategory>>enabledServices (in category 'accessing') ----- enabledServices ^ services select: [:e | e isEnabled]! ----- Method: ServiceCategory>>execute (in category 'executing') ----- execute "displays the subservices as a submenu" ServiceGui openMenuFor: self! ----- Method: ServiceCategory>>externalPreferences (in category 'preferences') ----- externalPreferences | p | p := ServicePreferences valueOfPreference: self childrenPreferences ifAbsent: ['']. ^ (p findTokens: ' ') collect: [:e | e service]! ----- Method: ServiceCategory>>initialize (in category 'initialize-release') ----- initialize services := OrderedCollection new. super initialize. ! ----- Method: ServiceCategory>>insertPreferences (in category 'preferences') ----- insertPreferences super insertPreferences. ServicePreferences addPreference: self childrenPreferences categories: { (#'-- menu contents --'). (self providerCategory)} default: '' balloonHelp: self description projectLocal: false changeInformee: self id -> #updateChildren changeSelector: #serviceUpdate type: #String! ----- Method: ServiceCategory>>isCategory (in category 'testing') ----- isCategory ^ true! ----- Method: ServiceCategory>>newChildren (in category 'preferences') ----- newChildren | s | s := ServicePreferences valueOfPreference: self childrenPreferences. ^ (s findTokens: ' ') collect: [:str | str serviceOrNil]! ----- Method: ServiceCategory>>newChildrenValid (in category 'preferences') ----- newChildrenValid | s | s := ServicePreferences valueOfPreference: self childrenPreferences. ^ (s findTokens: ' ') allSatisfy: [:str | str serviceOrNil ifNil: [ServiceRegistry ifInteractiveDo: [self inform: str, ' is not a valid service name']. false] ifNotNil: [true]]! ----- Method: ServiceCategory>>prefServices (in category 'preferences') ----- prefServices | s | s := ServicePreferences valueOfPreference: self childrenPreferences. ^ (s findTokens: ' ') collect: [:str | str service]! ----- Method: ServiceCategory>>replaceChildren (in category 'preferences') ----- replaceChildren ServiceRegistry ifInteractiveDo: [services do: [:s | s provider ifNotNil: [:p | p class removeSelector: (self id , s id) asSymbol]]]. services := self newChildren. services do: [:e | (ServicePreferences preferenceAt: e shortcutPreference) ifNotNil: [:p | p categoryList: {'-- keyboard shortcuts --'. self id asString}]. ServiceRegistry ifInteractiveDo: [self provider savePreferencesFor: self]]! ----- Method: ServiceCategory>>requestor: (in category 'accessing') ----- requestor: aRequestor super requestor: aRequestor. self services do: [:s | s requestor: aRequestor]! ----- Method: ServiceCategory>>services (in category 'accessing') ----- services ^services! ----- Method: ServiceCategory>>updateChildren (in category 'preferences') ----- updateChildren self newChildrenValid ifTrue: [self replaceChildren]. "PreferenceBrowserMorph updateBrowsers." ServiceGui updateBar: self! Object subclass: #ServiceGui instanceVariableNames: 'menu bar service n' classVariableNames: '' poolDictionaries: '' category: 'Services-Base-GUI'! ServiceGui class instanceVariableNames: 'bars'! !ServiceGui commentStamp: 'rr 7/10/2006 15:29' prior: 0! I abstract all the UI-related behaviors for the services framework. In the future I could be changed to be compatible with ToolBuilder! ServiceGui class instanceVariableNames: 'bars'! ----- Method: ServiceGui class>>bars (in category 'registering button bars') ----- bars ^ bars! ----- Method: ServiceGui class>>browser:classCategoryMenu: (in category 'hooks') ----- browser: b classCategoryMenu: aMenu ^ (self new for:b id:#browserClassCategoryMenu) inlineInMenu:aMenu! ----- Method: ServiceGui class>>browser:classMenu: (in category 'hooks') ----- browser: b classMenu: aMenu ^ (self new for:b id:#browserClassMenu) inlineInMenu:aMenu! ----- Method: ServiceGui class>>browser:codePaneMenu: (in category 'hooks') ----- browser: b codePaneMenu: aMenu ^(self new for: b id: #browserCodePaneMenu) inlineInMenu: aMenu! ----- Method: ServiceGui class>>browser:messageCategoryMenu: (in category 'hooks') ----- browser: b messageCategoryMenu: aMenu ^ (self new for:b id:#browserMethodCategoryMenu) inlineInMenu:aMenu! ----- Method: ServiceGui class>>browser:messageListMenu: (in category 'hooks') ----- browser: aBrowser messageListMenu: aMenu ^ (self new for: aBrowser id: #browserMethodMenu) inlineInMenu: aMenu! ----- Method: ServiceGui class>>browserButtonRow: (in category 'hooks') ----- browserButtonRow: aBrowser ^ (self new for: aBrowser id: #browserButtonBar) buildButtonBar ! ----- Method: ServiceGui class>>browserButtonRow:inlinedIn: (in category 'hooks') ----- browserButtonRow: aBrowser inlinedIn: row | bar | self buttonBarServices ifTrue: [bar := (self new for: aBrowser id: #browserButtonBar) buildButtonBar. row addMorphBack: bar]. ^ row! ----- Method: ServiceGui class>>buttonBarServices (in category 'preferences') ----- buttonBarServices ^ ServicePreferences valueOfPreference: #useServicesInBrowserButtonBar ! ----- Method: ServiceGui class>>initialize (in category 'registering button bars') ----- initialize bars := OrderedCollection new. (TheWorldMenu respondsTo: #registerOpenCommand:) ifTrue: [TheWorldMenu unregisterOpenCommand: 'Services Browser'. TheWorldMenu registerOpenCommand: {'Services Browser'. {PreferenceBrowser. #openForServices}}]! ----- Method: ServiceGui class>>inlineServices (in category 'preferences') ----- inlineServices ^ ServicePreferences valueOfPreference: #inlineServicesInMenu ! ----- Method: ServiceGui class>>onlyServices (in category 'preferences') ----- onlyServices ^ ServicePreferences valueOfPreference: #useOnlyServicesInMenu! ----- Method: ServiceGui class>>openMenuFor: (in category 'opening menus') ----- openMenuFor: aServiceCategory (self new menuFor: aServiceCategory) invokeModal! ----- Method: ServiceGui class>>registerBar:for: (in category 'registering button bars') ----- registerBar: aBar for: service self bars removeAllSuchThat: [:a | a value isNil]. self bars add: (WeakValueAssociation key: service value: aBar).! ----- Method: ServiceGui class>>updateBar: (in category 'registering button bars') ----- updateBar: cat self bars select: [:assoc | (assoc key id = cat id) & assoc value notNil] thenDo: [:assoc | | newBar | cat requestor: assoc key requestor. newBar := self new buttonBarFor: cat. assoc value removeAllMorphs. newBar submorphsDo: [:m | assoc value addMorphBack: m]]! ----- Method: ServiceGui class>>updateBars (in category 'registering button bars') ----- updateBars self bars do: [:assoc | | oldCat cat newBar bar | (bar := assoc value) ifNotNil: [ oldCat := assoc key. cat := oldCat id service. cat requestor: oldCat requestor. newBar := self new buttonBarFor: cat. bar removeAllMorphs. newBar submorphsDo: [:m | bar addMorphBack: m]]. ]! ----- Method: ServiceGui class>>updateMenu:forModel:selector: (in category 'hooks') ----- updateMenu: aMenu forModel: aModel selector: selector ('codePane*' match: selector) ifTrue: [ (self new for: aModel id: #codeSelectionRefactorings) inlineInMenu: aMenu]. ^ aMenu ! ----- Method: ServiceGui class>>worldMenu: (in category 'hooks') ----- worldMenu: aMenu ^ (self new for: aMenu id: #world) inlineInMenu: aMenu! ----- Method: ServiceGui>>bar (in category 'accessing') ----- bar ^ bar! ----- Method: ServiceGui>>buildButtonBar (in category 'building') ----- buildButtonBar bar := self buttonBarFor: service. self class registerBar: bar for: service. ^ bar! ----- Method: ServiceGui>>buttonBarFor: (in category 'servicecategory') ----- buttonBarFor: aServiceCategory self styleBar: self bar. aServiceCategory enabledServices do: [:each | self bar addMorphBack: (self buttonFor: each)]. ^ self bar! ----- Method: ServiceGui>>buttonFor: (in category 'services') ----- buttonFor: aService ^ aService isCategory ifTrue: [self buttonForCategory: aService] ifFalse: [self buttonForAction: aService]! ----- Method: ServiceGui>>buttonForAction: (in category 'serviceactions') ----- buttonForAction: aService "see getstate for availability?" | aButton | aButton := PluggableButtonMorph on: aService getState: nil action: #execute. self styleButton: aButton. aButton label: aService buttonLabel; setBalloonText: aService description. ^aButton! ----- Method: ServiceGui>>buttonForCategory: (in category 'servicecategory') ----- buttonForCategory: aService "see getstate for availability?" | aButton | aButton := PluggableButtonMorph on: [:button | aService requestor: button requestor. self class openMenuFor: aService] getState: nil action: #value:. aButton arguments: (Array with: aButton). self styleButton: aButton. aButton label: aService buttonLabel. ^aButton! ----- Method: ServiceGui>>for:id: (in category 'initialization') ----- for: caller id: id service := id service. caller ifNotNil: [service requestor: caller requestor]! ----- Method: ServiceGui>>initialize (in category 'initialization') ----- initialize super initialize. menu := OrderedCollection new. bar := AlignmentMorph newRow. n := OrderedCollection with: 0! ----- Method: ServiceGui>>inlineInMenu: (in category 'building') ----- inlineInMenu: aMenu ^ self class inlineServices ifTrue: [self inlineInMenu: aMenu for: service] ifFalse: [aMenu]! ----- Method: ServiceGui>>inlineInMenu:for: (in category 'servicecategory') ----- inlineInMenu: aMenu for: aServiceCategory menu addLast: aMenu. aServiceCategory enabledServices do: [:each | self menuItemFor: each]. ^ self popMenu! ----- Method: ServiceGui>>menu (in category 'accessing') ----- menu ^ menu last! ----- Method: ServiceGui>>menuFor: (in category 'servicecategory') ----- menuFor: aServiceCategory | submenu | submenu := self subMenuFor: aServiceCategory. ^ submenu addTitle: (aServiceCategory menuLabel)! ----- Method: ServiceGui>>menuItemFor: (in category 'services') ----- menuItemFor: aService [aService isCategory ifTrue: [self menuItemForCategory: aService] ifFalse: [self menuItemForAction: aService]] on: Error do: [:er | (self confirm: 'menuItemFor: error. debug?') ifTrue: [er signal]]! ----- Method: ServiceGui>>menuItemForAction: (in category 'serviceactions') ----- menuItemForAction: aServiceAction "Returns a menuItem triggering self" self menu add: (aServiceAction menuLabelNumbered: self n) target: aServiceAction selector: #execute. Smalltalk isMorphic ifTrue: [ self menu lastItem isEnabled: aServiceAction executeCondition. self menu balloonTextForLastItem: aServiceAction description]! ----- Method: ServiceGui>>menuItemForCategory: (in category 'servicecategory') ----- menuItemForCategory: aServiceCategory "Returns a menuItem triggering self" | submenu | submenu := self subMenuFor: aServiceCategory. self menu add: (aServiceCategory menuLabelNumbered: self n) subMenu: submenu! ----- Method: ServiceGui>>n (in category 'servicecategory') ----- n ^ n last! ----- Method: ServiceGui>>n: (in category 'servicecategory') ----- n: nn n removeLast. n addLast: nn! ----- Method: ServiceGui>>popMenu (in category 'servicecategory') ----- popMenu | aMenu | aMenu := menu removeLast. n removeLast. self styleMenu: aMenu. ^ aMenu! ----- Method: ServiceGui>>pushMenu (in category 'servicecategory') ----- pushMenu menu addLast: MenuMorph new. n addLast: 0! ----- Method: ServiceGui>>styleBar: (in category 'styling') ----- styleBar: aBar aBar setNameTo: 'button bar'. aBar beSticky; hResizing: #spaceFill; wrapCentering: #center; cellPositioning: #leftCenter; clipSubmorphs: true; cellInset: 0; color: Preferences defaultWindowColor.! ----- Method: ServiceGui>>styleButton: (in category 'styling') ----- styleButton: aButton aButton color: Color transparent; onColor: Color transparent offColor: Color transparent; borderStyle: (BorderStyle width: 1 color: Color gray); askBeforeChanging: true; clipSubmorphs: true; hResizing: #spaceFill; vResizing: #spaceFill. ^ self! ----- Method: ServiceGui>>styleMenu: (in category 'styling') ----- styleMenu: aMenu "gradient, etc ..?" "aMenu color: Color white; borderStyle: (BorderStyle width: 1 color: Color gray); clipSubmorphs: true; addDropShadow; shadowColor: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.666); shadowOffset: 1 @ 1"! ----- Method: ServiceGui>>subMenuFor: (in category 'servicecategory') ----- subMenuFor: aServiceCategory self pushMenu. aServiceCategory enabledServices ifEmpty: [self menuItemFor: ServiceAction new]. aServiceCategory enabledServices doWithIndex: [:each :i | self n: i. self menuItemFor: each]. ^ self popMenu! Object subclass: #ServiceProvider instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Services-Base'! !ServiceProvider commentStamp: 'rr 7/10/2006 15:08' prior: 0! A ServiceProvider references services that are relevant to a given application. Each application that wishes to use the Services framework must subclass a ServiceProvider. This class must define a 'services' method category. Each method implemented in this category will be automatically called by the framework. Each of these method should be a unary message (taking no argument), and return a fully initialised instance of ServiceAction or ServiceCategory. There are three possible patterns: 1) serviceIdentifierAndMethodName ^ ServiceAction text: 'Menu item text' button: 'Button text' description: 'Longer text that appears in help balloons' action: [:r | "Code block fetching data from the requestor instance, r, that is passed to the block"] 2) serviceIdentifierAndMethodName ^ ServiceAction text: 'Menu item text' button: 'Button text' description: 'Longer text that appears in help balloons' action: [:r | "Code block fetching data from the requestor instance, r, that is passed to the block"] condition: [:r | "second block returning true if the service can be used at the time being, false otherwise. Data can still be fetched from the requestor instance"] 3) methodNameAndServiceCategoryId ^ ServiceCategory text: 'Menu text' button: 'Button text' description: 'Longer descriptive text appearing in help balloons' The organisation of services into categories, and the services bound to keyboard shortcuts are specified using the Services Browser (see the comment on the class ServicesPreferences for more details). When editing preferences, they are saved as methods on the ServiceProvider, all defined in the 'saved preferences' method category. Each of thesse methods stores preferences that the provider can replay. ! ServiceProvider subclass: #BrowserProvider instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Services-Base-Providers'! !BrowserProvider commentStamp: 'rr 7/10/2006 15:17' prior: 0! I define the default categories of services dealing with browsing: - the class category menu (service identifier: browserClassCategoryMenu) - the class menu (browserClassMenu) - the method category menu (browserMethodCategoryMenu) - the browser method menu (browserMethodMenu) - the browser button bar (browserButtonBar) - the browser code pane/selection menu (browserCodePaneMenu)! ----- Method: BrowserProvider class>>initialize (in category 'initialize-release') ----- initialize ServiceRegistry current buildProvider: self new! ----- Method: BrowserProvider>>browser (in category 'services') ----- browser ^ ServiceCategory text: 'Browser' button: 'browser' description: 'The browser menus'! ----- Method: BrowserProvider>>browserButtonBar (in category 'services') ----- browserButtonBar ^ ServiceCategory text:'button bar' button:'button' description:'the browser button bar'! ----- Method: BrowserProvider>>browserClassCategoryMenu (in category 'services') ----- browserClassCategoryMenu ^ ServiceCategory text:'Class Category' button:'class cat' description:'The browser class category menu'! ----- Method: BrowserProvider>>browserClassMenu (in category 'services') ----- browserClassMenu ^ ServiceCategory text:'Class' button:'class' description:'The browser class menu'! ----- Method: BrowserProvider>>browserClassMenushortcut (in category 'saved preferences') ----- browserClassMenushortcut ^ #(#'Shortcut for browserClassMenu:' '' 1000 )! ----- Method: BrowserProvider>>browserCodePaneMenu (in category 'services') ----- browserCodePaneMenu ^ ServiceCategory text: 'Code Pane' button: 'pane' description: 'The browser code pane menu'! ----- Method: BrowserProvider>>browserMethodCategoryMenu (in category 'services') ----- browserMethodCategoryMenu ^ ServiceCategory text:'Method Category' button:'method cat' description:'The browser method menu'! ----- Method: BrowserProvider>>browserMethodMenu (in category 'services') ----- browserMethodMenu ^ ServiceCategory text:'Method' button:'method' description:'The browser method menu'! ----- Method: BrowserProvider>>browserMethodMenushortcut (in category 'saved preferences') ----- browserMethodMenushortcut ^ #(#'Shortcut for browserMethodMenu:' '' 1000 )! ----- Method: ServiceProvider class>>newProviderFor: (in category 'provider creation') ----- newProviderFor: packageName | cls clsName | clsName := ((packageName copyWithout: $-) , 'ServiceProvider') asSymbol. cls := self subclass: clsName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: packageName. cls class compile: 'initialize ServiceRegistry buildProvider: self new' classified: 'initialization'. ^ cls! ----- Method: ServiceProvider class>>registeredProviders (in category 'accessing') ----- registeredProviders ^ self allSubclasses collect: [:each | each new]! ----- Method: ServiceProvider>>performAndSetId: (in category 'accessing') ----- performAndSetId: aSymbol | service | service := self perform: aSymbol. service id: aSymbol. ^service! ----- Method: ServiceProvider>>registeredServices (in category 'accessing') ----- registeredServices ^ self services collect: [:each | self performAndSetId: each]! ----- Method: ServiceProvider>>replayPreferences (in category 'persistence') ----- replayPreferences ServicePreferences replayPreferences: self savedPreferences! ----- Method: ServiceProvider>>savePreferencesFor: (in category 'persistence') ----- savePreferencesFor: aService "pref := ServicePreferences preferenceAt: aService shortcutPreference. strm := WriteStream with: ''. strm nextPutAll: aService id; nextPutAll: 'shortcut'; cr; tab; nextPutAll: '^ '; nextPutAll: {pref name. pref preferenceValue. 1000} storeString. self class compileSilently: strm contents classified: 'saved preferences'." aService isCategory ifTrue: [aService externalPreferences doWithIndex: [:e :i | | strm | strm := WriteStream with: aService id asString. strm nextPutAll: e id asString; cr; tab; nextPutAll: '^ '; nextPutAll: {aService childrenPreferences. e id. i} storeString. e provider class compileSilently: strm contents classified: 'saved preferences']]! ----- Method: ServiceProvider>>savedPreferences (in category 'persistence') ----- savedPreferences ^ (self class organization listAtCategoryNamed: #'saved preferences') collect: [:e | self perform: e]! ----- Method: ServiceProvider>>services (in category 'accessing') ----- services ^ self class organization listAtCategoryNamed: #services! ServiceProvider subclass: #WorldMenuProvider instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Services-Base-Providers'! !WorldMenuProvider commentStamp: 'rr 7/10/2006 15:19' prior: 0! I define services and categories: - The world menu category (identifier: world), where services and categories can be put to be displayed in the world menu. - The preferencesMenu category, where services about services and preferences can be put - th open menu! ----- Method: WorldMenuProvider class>>initialize (in category 'initialize-release') ----- initialize ServiceRegistry current buildProvider: self new! ----- Method: WorldMenuProvider>>browserMethodMenucreateNewService (in category 'saved preferences') ----- browserMethodMenucreateNewService ^ #(#'Items in browserMethodMenu:' #createNewService 1 )! ----- Method: WorldMenuProvider>>closeTopWindow (in category 'services') ----- closeTopWindow ^ ServiceAction text: 'Close top window' button: 'close window' description: 'Closes the focused window' action: [:r | SystemWindow topWindow delete]! ----- Method: WorldMenuProvider>>convertOpenCommand: (in category 'service registering') ----- convertOpenCommand: array | description | description := array size > 2 ifTrue: [array third] ifFalse: ['none available']. ^ServiceAction id: array first asSymbol text: array first button: array first description: description action: [array second first perform: array second second]! ----- Method: WorldMenuProvider>>createNewService (in category 'services') ----- createNewService ^ ServiceAction text: 'Create new service' button: 'new service' description: 'Define a new service provided by this package' action: [:r | | s p | s := r caption: 'enter service identifier'; getSymbol. p := r getPackageProvider. p compile: s, ' ^ ServiceAction "Open the service browser to set the menu position and the keyboard shortcut" text: ''fill menu label'' button: ''short button text'' description: ''longer text for balloon help'' action: [:r | "action block"] condition: [:r | "optional condition block"]' classified: 'services'. r getBrowser browseReference: (MethodReference class: p selector: s)]! ----- Method: WorldMenuProvider>>helpOnServices (in category 'services') ----- helpOnServices ^ ServiceAction text: 'Help on Services' button: 'services help' description: 'Introductory text about services' action: [StringHolder new contents: self servicesHelpText; openLabel: 'Introduction to Services'].! ----- Method: WorldMenuProvider>>nextWindow (in category 'services') ----- nextWindow ^ ServiceAction text: 'Switch to next window' button: 'next window' description: 'Switches to the next window' action: [:r | SystemWindow sendTopWindowToBack]! ----- Method: WorldMenuProvider>>openMenu (in category 'services') ----- openMenu ^ ServiceCategory text: 'Open' button: 'open' description: 'The open menu'! ----- Method: WorldMenuProvider>>preferencesBrowser (in category 'services') ----- preferencesBrowser ^ ServiceAction text: 'Preference Browser' button: 'pref. browser' description: 'Open the preference browser to edit various Squeak settings' action: [PreferenceBrowser open].! ----- Method: WorldMenuProvider>>preferencesMenu (in category 'services') ----- preferencesMenu ^ ServiceCategory text: 'Preferences & Services' button: 'preferences' description: 'Menu related to editing preferences'! ----- Method: WorldMenuProvider>>preferencesMenuhelpOnServices (in category 'saved preferences') ----- preferencesMenuhelpOnServices ^ #(#'Items in preferencesMenu:' #helpOnServices 3 )! ----- Method: WorldMenuProvider>>preferencesMenupreferencesBrowser (in category 'saved preferences') ----- preferencesMenupreferencesBrowser ^ #(#'Items in preferencesMenu:' #preferencesBrowser 1 )! ----- Method: WorldMenuProvider>>preferencesMenurebuildRegistry (in category 'saved preferences') ----- preferencesMenurebuildRegistry ^ #(#'Items in preferencesMenu:' #rebuildRegistry 4 )! ----- Method: WorldMenuProvider>>preferencesMenuservicesBrowser (in category 'saved preferences') ----- preferencesMenuservicesBrowser ^ #(#'Items in preferencesMenu:' #servicesBrowser 2 )! ----- Method: WorldMenuProvider>>preferencesMenushortcut (in category 'saved preferences') ----- preferencesMenushortcut ^ #(#'Shortcut for preferencesMenu:' '' 1000 )! ----- Method: WorldMenuProvider>>rebuildRegistry (in category 'services') ----- rebuildRegistry ^ ServiceAction text: 'Rebuild service registry' button: 'rebuild registry' description: 'Rebuilds the service registry to scan for newly defined services' action: [ServiceRegistry rebuild].! ----- Method: WorldMenuProvider>>servicesBrowser (in category 'services') ----- servicesBrowser ^ ServiceAction text: 'Services Browser' button: 'services' description: 'Open a preference browser to edit several Squeak menus' action: [PreferenceBrowser openForServices].! ----- Method: WorldMenuProvider>>servicesHelpText (in category 'accessing') ----- servicesHelpText ^ ' This is an overview of the main concepts of the services framework. More details are available in class comments. The aim is to help you defining services step by step. The three main classes are: -ServiceAction -ServiceCategory -ServiceProvider Alongside them, a tool to use is the Services Browser. It can be found in the world menu, under the ''Preferences & Services'' menu heading (in which you found this text). ServiceAction are executable objects in various contexts. They can be displayed as buttons or menu items or bounded to keyboard shortcuts. ServiceCategory are categories of services. They are also services, so a ServiceCategory can be included in another, forming a tree of Services. ServiceCategories can be displayed with menus, or button bars. A ServiceProvider references services that are relevant to a given application. Each application that wishes to use the Services framework must subclass a ServiceProvider. This class must define a ''services'' method category. Each method implemented in this category will be automatically called by the framework. Each of these method should be a unary message (taking no argument), and return a fully initialised instance of ServiceAction or ServiceCategory. There are three possible patterns: 1) serviceIdentifierAndMethodName ^ ServiceAction text: ''Menu item text'' button:''Button text'' description: ''Longer text that appears in help balloons'' action: [:r | "Code block fetching data from the requestor instance, r, that is passed to the block"] 2) serviceIdentifierAndMethodName ^ ServiceAction text: ''Menu item text'' button: ''Button text'' description: ''Longer text that appears in help balloons'' action: [:r | "Code block fetching data from the requestor instance, r, that is passed to the block"] condition: [:r | "second block returning true if the service can be used at the time being, false otherwise. Data can still be fetched from the requestor instance"] 3) methodNameAndServiceCategoryId ^ ServiceCategory text: ''Menu text'' button: ''Button text'' description: ''Longer descriptive text appearing in help balloons'' The block given to the ServiceActions can take an instance of the Requestor class as parameter. You can fetch data from these. The generic format is to call methods starting with ''get'' on the requestor, like getClass, getMessageName for services related to the browser. The organisation of services into categories, and the services bound to keyboard shortcuts are specified using the Services Browser, based on the Preference Browser by Hernan Tylim. When editing preferences, they are saved as methods on the ServiceProvider, all defined in the ''saved preferences'' method category. When opening the Services Browser you see a list of preference categories on the left, and the preferences inside this category on the right. The main preference categories for services are: -- keyboard shortcuts -- : several text preferences, one per keyboard shortcuts. To edit them, enter a service identifier (equal to the method name under which it is defined in its ServiceProvider), and accept with alt-s or enter -- menu contents -- : All the service categories in the image have a text preference under here. To edit it, enter the services identifiers you wish to put in this category, separating them with a single space character. The order is important: it defines the order of the items in menus. -- settings -- : general boolean preferences. Then there is a preference category for each provider in the image. Under each, you will find: A boolean preference for each service in the image. If it is false, the service will not appear in menus. The text preference for each service category defined by the service provider. This is the same as the one appearing in the menu contents preference category. Some identifiers of categories already appearing in the UI are: - world : the world menu - preferencesMenu - browserClasssCategoryMenu - browserClassMenu - browserMethodCategoryMenu - browserMethodMenu - browserCodePaneMenu - browserButtonBar After editing these preferences to match the services and categories you defined for your application, you should be done. Romain Robbes'! ----- Method: WorldMenuProvider>>world (in category 'services') ----- world ^ ServiceCategory text: 'World' button: 'world' description: 'The world menu'! ----- Method: WorldMenuProvider>>worldpreferencesMenu (in category 'saved preferences') ----- worldpreferencesMenu ^ #(#'Items in world:' #preferencesMenu 1 )! ----- Method: WorldMenuProvider>>worldshortcut (in category 'saved preferences') ----- worldshortcut ^ #(#'Shortcut for world:' '' 1000 )! Object subclass: #ServiceRegistry instanceVariableNames: 'services interactive' classVariableNames: 'Current' poolDictionaries: '' category: 'Services-Base'! !ServiceRegistry commentStamp: 'rr 7/10/2006 15:10' prior: 0! The ServiceRegistry is the repository in which services are stored. They are stored in a dictionary, and keyed by their identifier (which is the name of the method they were defined in). The registry handles the intialization, building and referencing processes as well.! ----- Method: ServiceRegistry class>>current (in category 'as yet unclassified') ----- current ^ Current ifNil: [Current := self new]! ----- Method: ServiceRegistry class>>ifInteractiveDo: (in category 'as yet unclassified') ----- ifInteractiveDo: aBlock self current isInteractive ifTrue: [aBlock value]! ----- Method: ServiceRegistry class>>initialize (in category 'as yet unclassified') ----- initialize self rebuild. SystemChangeNotifier uniqueInstance notify: self ofSystemChangesOfItem: #method using: #methodChanged: ! ----- Method: ServiceRegistry class>>methodChanged: (in category 'as yet unclassified') ----- methodChanged: event self ifInteractiveDo: [ | cls | cls := event itemClass. ((event changeKind = #removed) not & (cls inheritsFrom: ServiceProvider) and: [cls new services includes: event itemSelector]) ifTrue: [[self current addService: (cls new performAndSetId: event itemSelector) provider: cls] on: Error do: [self inform: 'Service format seems to be incorrect']]]! ----- Method: ServiceRegistry class>>rebuild (in category 'as yet unclassified') ----- rebuild | old | old := Current. [Current := self new. Current build] on: Error do: [:err | (self confirm: 'An error occured during build. Debug it?') ifTrue: [err signal]. Current := old]! ----- Method: ServiceRegistry>>addService:provider: (in category 'building') ----- addService: aService provider: p services at:aService id put:aService. aService provider: p. aService insertPreferences ! ----- Method: ServiceRegistry>>beNotInteractiveDuring: (in category 'building') ----- beNotInteractiveDuring: aBlock interactive := false. aBlock value. interactive := true! ----- Method: ServiceRegistry>>build (in category 'building') ----- build "ServicePreferences wipe." self beNotInteractiveDuring: [ | pr | ServiceProvider registeredProviders do: [:p | p registeredServices do: [:each | self addService: each provider: p class]]. pr := ServiceProvider registeredProviders gather: [:p | p savedPreferences]. ServicePreferences replayPreferences: pr. ]. ServiceGui updateBars. ServiceShortcuts setPreferences! ----- Method: ServiceRegistry>>buildProvider: (in category 'building') ----- buildProvider: p self beNotInteractiveDuring: [ p registeredServices do: [:each | self addService: each provider: p class]. p replayPreferences] ! ----- Method: ServiceRegistry>>categories (in category 'accessing') ----- categories ^ self serviceCollection select: [:s | s isCategory]! ----- Method: ServiceRegistry>>initialize (in category 'initialize-release') ----- initialize services := Dictionary new. interactive := true! ----- Method: ServiceRegistry>>isInteractive (in category 'accessing') ----- isInteractive ^ interactive! ----- Method: ServiceRegistry>>serviceCollection (in category 'accessing') ----- serviceCollection ^ services asArray! ----- Method: ServiceRegistry>>serviceWithId: (in category 'accessing') ----- serviceWithId: aSymbol ^ services at: aSymbol ifAbsent: [nil]! ----- Method: ServiceRegistry>>services (in category 'accessing') ----- services ^ self serviceCollection reject: [:s | s isCategory]! Object subclass: #ServiceShortcuts instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Services-Base'! ServiceShortcuts class instanceVariableNames: 'map'! !ServiceShortcuts commentStamp: 'rr 7/10/2006 15:14' prior: 0! A data structures implementing a simple form of keyboard shortucts is defined on the class side. Available keyboard shortcuts are: command-0 to command-9 (command is also called alt on some systems). control-0 to control-0 command-control-0 to command-control-9 (command is also alt) control-command-left arrow control-command-up arrow control-command-right arrow control-command-down arrow Using the Services Browser (see class ServicePreferences), these shortcuts can be bound to service identifiers.! ServiceShortcuts class instanceVariableNames: 'map'! ----- Method: ServiceShortcuts class>>arrowShortcut:event: (in category 'as yet unclassified') ----- arrowShortcut: str event: event | key s | key := event keyCharacter caseOf: { [Character arrowDown] -> ['down']. [Character arrowUp] -> ['up']. [Character arrowLeft] -> ['left']. [Character arrowRight] -> ['right']}. s := self map at: str , key ifAbsent: [^ self]. s serviceOrNil ifNotNil: [:sv | sv execute. event wasHandled: true]! ----- Method: ServiceShortcuts class>>changeShortcut:to: (in category 'as yet unclassified') ----- changeShortcut: shortcut to: aString aString isBlock ifTrue: [^self map at: shortcut put: aString]. (aString beginsWith: '[') ifTrue: [^self map at: shortcut put: aString]. aString isEmpty ifTrue: [self map removeKey: shortcut ifAbsent: []] ifFalse: [self map at: shortcut put: aString]! ----- Method: ServiceShortcuts class>>handleKeystroke: (in category 'as yet unclassified') ----- handleKeystroke: event [event isKeystroke ifTrue: [self process: event]] on: Error do: [:e | (self confirm: 'shortcut error. debug?') ifTrue: [e signal]]! ----- Method: ServiceShortcuts class>>insertPrefShortcut: (in category 'as yet unclassified') ----- insertPrefShortcut: short ServicePreferences addPreference: short categories: #('-- keyboard shortcuts --' ) default: '' balloonHelp: 'enter a service id to bind it to this shortcut' projectLocal: false changeInformee: [self changeShortcut: short to: (ServicePreferences valueOfPreference: short)] changeSelector: #value type: #String! ----- Method: ServiceShortcuts class>>map (in category 'as yet unclassified') ----- map ^ map ifNil: [map := Dictionary new]! ----- Method: ServiceShortcuts class>>process: (in category 'as yet unclassified') ----- process: event event keyCharacter isDigit ifTrue: [event commandKeyPressed & event controlKeyPressed ifTrue: [^ self shortcut: 'ctrl-cmd-' event: event]. event commandKeyPressed ifTrue: [^ self shortcut: 'cmd-' event: event]. event controlKeyPressed ifTrue: [^ self shortcut: 'ctrl-' event: event]]. ({Character arrowUp. Character arrowDown. Character arrowLeft. Character arrowRight} includes: event keyCharacter) ifTrue: [event commandKeyPressed & event controlKeyPressed ifTrue: [^ self arrowShortcut: 'ctrl-cmd-' event: event]. ]! ----- Method: ServiceShortcuts class>>setPreferences (in category 'as yet unclassified') ----- setPreferences | mm | mm := self map copy. (0 to: 9) do: [:i | #('ctrl-' 'cmd-' 'ctrl-cmd-' ) do: [:str | | short | short := (str , i asString) asSymbol. self insertPrefShortcut: short]]. #(#up #down #left #right ) do: [:s | self insertPrefShortcut: ('ctrl-cmd-' , s) asSymbol.]. mm keysAndValuesDo: [:k :v | ServicePreferences setPreference: k toValue: v]. ((Array new: 3) at: 1 put: ((Array new: 3) at: 1 put: #inlineServicesInMenu; at: 2 put: true; at: 3 put: 'Inline services within squeak menus'; yourself); at: 2 put: ((Array new: 3) at: 1 put: #useOnlyServicesInMenu; at: 2 put: false; at: 3 put: 'Use only services and not regular menu items'; yourself); at: 3 put: ((Array new: 3) at: 1 put: #useServicesInBrowserButtonBar; at: 2 put: true; at: 3 put: 'Use a service-based button bar'; yourself); yourself) do: [:tr | ServicePreferences addPreference: tr first categories: #('-- settings --' ) default: tr second balloonHelp: tr third]! ----- Method: ServiceShortcuts class>>shortcut:event: (in category 'as yet unclassified') ----- shortcut: str event: event | s | Transcript cr. s := self map at: str , event keyCharacter asString ifAbsent: [^ self]. (s beginsWith: '[') ifTrue: [^ (Compiler evaluateUnloggedForSelf: s) value]. s serviceOrNil ifNotNil: [:sv | sv execute. event wasHandled: true]! ----- Method: FillInTheBlankMorph>>selection (in category '*services-base') ----- selection "answers what is actually selected in the morph" ^ textPane selectionInterval! ----- Method: BlockClosure>>valueWithRequestor: (in category '*services-base') ----- valueWithRequestor: aRequestor "To do later: make the fillInTheBlank display more informative captions. Include the description of the service, and maybe record steps" ^ self numArgs isZero ifTrue: [self value] ifFalse: [self value: aRequestor]! ----- Method: SequenceableCollection>>startsWith: (in category '*services-base') ----- startsWith: start | comp | self deprecated: 'Use #beginsWith:'. self size < start size ifTrue: [^ false]. comp := true. (self first: start size) with: start do: [:ea :ea2 | ea = ea2 ifFalse: [comp := false]]. ^ comp! ----- Method: Morph>>requestor (in category '*services-base') ----- requestor ^ owner ifNil: [super requestor] ifNotNil: [owner requestor]! Warning subclass: #ServiceCancelled instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Services-Base'! !ServiceCancelled commentStamp: 'rr 4/1/2004 18:24' prior: 0! Exception raised when a service is cancelled, to inform the user.! ----- Method: ServiceCancelled>>defaultAction (in category 'handling') ----- defaultAction Transcript cr; show: 'service has been cancelled'! ----- Method: ServiceCancelled>>messageText (in category 'accessing') ----- messageText ^ 'Service has been cancelled'! ----- Method: CodeHolder>>messageListMenuServices: (in category '*services-base') ----- messageListMenuServices: aMenu <messageListMenu> <menuPriority: 150> ServiceGui browser: self messageListMenu: aMenu. ^ Preferences useOnlyServicesInMenu ifTrue: [nil] ifFalse: [aMenu]! ----- Method: CodeHolder>>requestor (in category '*services-base') ----- requestor ^ (BrowserRequestor new) browser: self; yourself! ----- Method: Browser>>browseReference: (in category '*services-base') ----- browseReference: ref self okToChange ifTrue: [ self selectCategoryForClass: ref actualClass theNonMetaClass. self selectClass: ref actualClass theNonMetaClass . ref actualClass isMeta ifTrue: [self indicateClassMessages]. self changed: #classSelectionChanged. self selectMessageCategoryNamed: ref category. self selectedMessageName: ref methodSymbol. ]! ----- Method: Browser>>classCategoryMenuServices: (in category '*services-base') ----- classCategoryMenuServices: aMenu <systemCategoryMenu> <menuPriority: 150> ServiceGui browser: self classCategoryMenu: aMenu. ^ Preferences useOnlyServicesInMenu ifTrue: [nil] ifFalse: [aMenu]! ----- Method: Browser>>classListMenuServices: (in category '*services-base') ----- classListMenuServices: aMenu <classListMenu> <menuPriority: 150> ServiceGui browser: self classMenu: aMenu. ^ Preferences useOnlyServicesInMenu ifTrue: [nil] ifFalse: [aMenu]! ----- Method: Browser>>messageCategoryMenuServices: (in category '*services-base') ----- messageCategoryMenuServices: aMenu <messageCategoryMenu> <menuPriority: 150> ServiceGui browser: self messageCategoryMenu: aMenu. ^ Preferences useOnlyServicesInMenu ifTrue: [nil] ifFalse: [aMenu]! ----- Method: Browser>>methodReference (in category '*services-base') ----- methodReference | cls sel | cls := self selectedClassOrMetaClass. sel := self selectedMessageName. cls isNil | sel isNil ifTrue: [^nil]. ^ MethodReference class: cls selector: sel! ----- Method: Browser>>optionalButtonRow (in category '*services-base') ----- optionalButtonRow ^ServiceGui browserButtonRow: self inlinedIn: super optionalButtonRow! ----- Method: Browser>>selectReference: (in category '*services-base') ----- selectReference: ref self browseReference: ref!

1 0

Squeak 4.6: VersionNumber-cmm.4.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of VersionNumber to project Squeak 4.6: http://source.squeak.org/squeak46/VersionNumber-cmm.4.mcz ==================== Summary ==================== Name: VersionNumber-cmm.4 Author: cmm Time: 9 June 2012, 1:50:58.564 pm UUID: 68fb1f05-d3e2-4c9b-9234-20a9bed166dc Ancestors: VersionNumber-nice.3 Strengthen VersionNumber>>#=. ==================== Snapshot ==================== SystemOrganization addCategory: #VersionNumber! Magnitude subclass: #VersionNumber instanceVariableNames: 'numbers' classVariableNames: '' poolDictionaries: '' category: 'VersionNumber'! !VersionNumber commentStamp: '<historical>' prior: 0! I am a version number. My representation allows me to handle an entire tree of versions. Once created, an instance should not change (note: VersionNumbers could be canonicalized like Symbols, but are not currently). I am a magnitude so that you can see if one version preceeds another (only if the two versions are in the same branch). '2.1' asVersion < '2.2.1' asVersion "true" '2.3' asVersion < '2.2.1' asVersion "error different branches" '2.3' asVersion inSameBranchAs: '2.2.1' asVersion "false, why the previous one failed." '2.1' asVersion = '2.1' asVersion "true, obviously" To get the next version number in the same branch: '2.3.4' asVersion next "2.3.5" To get the next version number, starting a new branch: '2.3.4' asVersion branchNext "2.3.4.1" To get the common base version of any two version numbers (useful for merging): '2.3.8' asVersion commonBase: '2.3.4.1' asVersion "2.3.4"! ----- Method: VersionNumber class>>first (in category 'as yet unclassified') ----- first ^self fromCollection: #(1)! ----- Method: VersionNumber class>>fromCollection: (in category 'as yet unclassified') ----- fromCollection: aCollection ^self new initializeNumbers: aCollection; yourself! ----- Method: VersionNumber class>>fromString: (in category 'as yet unclassified') ----- fromString: aString ^self fromCollection: ((aString findTokens: '.') collect: [:ea | ea asNumber ]) ! ----- Method: VersionNumber>>< (in category 'comparing') ----- < another "Answer whether the receiver is less than the argument." | tmp | (self inSameBranchAs: another) ifFalse: [^self error: 'Receiver and argument in different branches']. tmp := another numbers. (tmp size = numbers size) ifTrue: [1 to: numbers size do: [ :in | (numbers at: in) < (tmp at: in) ifTrue: [^true]]. ^false]. ^numbers size < tmp size ! ----- Method: VersionNumber>>= (in category 'comparing') ----- = aVersion self == aVersion ifTrue: [ ^ true ]. aVersion species = self species ifFalse: [ ^ false ]. ^ numbers = aVersion numbers! ----- Method: VersionNumber>>branchNext (in category 'accessing') ----- branchNext ^self class fromCollection: (numbers, (Array with: 1))! ----- Method: VersionNumber>>commonBase: (in category 'accessing') ----- commonBase: aVersion | smallNums largeNums cutoff | (aVersion numbers size <= numbers size) ifTrue: [smallNums := aVersion numbers. largeNums := numbers] ifFalse: [smallNums := numbers. largeNums := aVersion numbers]. cutoff := (1 to: smallNums size) detect: [ :in | ((smallNums at: in) ~= (largeNums at: in))] ifNone: [^self class fromCollection: smallNums]. ^self class fromCollection: ((numbers copyFrom: 1 to: (cutoff - 1)), (Array with: ((smallNums at: cutoff) min: (largeNums at: cutoff)))) ! ----- Method: VersionNumber>>hash (in category 'comparing') ----- hash ^numbers hash! ----- Method: VersionNumber>>inSameBranchAs: (in category 'testing') ----- inSameBranchAs: aVersion | less more | (aVersion numbers size <= numbers size) ifTrue: [less := aVersion numbers. more := numbers] ifFalse: [less := numbers. more := aVersion numbers]. 1 to: (less size - 1) do: [ :in | ((less at: in) = (more at: in)) ifFalse: [^false]]. ^less size = more size or: [(less at: less size) <= (more at: less size)] ! ----- Method: VersionNumber>>initializeNumbers: (in category 'initialization') ----- initializeNumbers: aCollection aCollection do: [ :ea | ea <= 0 ifTrue: [^self error: 'VersionNumbers cannot contain zero or negative numbers']]. numbers := aCollection asArray! ----- Method: VersionNumber>>next (in category 'accessing') ----- next | tmp | tmp := numbers copy. tmp at: numbers size put: (numbers last + 1). ^self class fromCollection: tmp! ----- Method: VersionNumber>>numbers (in category 'accessing') ----- numbers "Answer a copy (to discourage people from directly changing a version number). VersionNumbers should never change, instead, instantiate a new instance." ^numbers copy! ----- Method: VersionNumber>>previous (in category 'accessing') ----- previous | tmp | numbers last = 1 ifTrue: [^self class fromCollection: (numbers allButLast)]. tmp := numbers copy. tmp at: numbers size put: (numbers last - 1). ^self class fromCollection: tmp ! ----- Method: VersionNumber>>printOn: (in category 'printing') ----- printOn: strm self storeOn: strm! ----- Method: VersionNumber>>storeOn: (in category 'printing') ----- storeOn: strm strm nextPut: $'. self versionStringOn: strm. strm nextPutAll: ''' asVersion'.! ----- Method: VersionNumber>>versionString (in category 'printing') ----- versionString ^String streamContents: [ :strm | self versionStringOn: strm ]! ----- Method: VersionNumber>>versionStringOn: (in category 'printing') ----- versionStringOn: strm | first | first := true. numbers do: [ :ea | first ifFalse: [strm nextPut: $.]. first := false. ea printOn: strm] ! Object subclass: #VersionHistory instanceVariableNames: 'versions' classVariableNames: '' poolDictionaries: '' category: 'VersionNumber'! !VersionHistory commentStamp: '<historical>' prior: 0! I am a version history. A version history is a collection of VersionNumbers that together form a tree of versions. I enforce rules about how versions are added and removed from the history. To add a new version to a VersionHistory based on an existing version: VersionHistory startingAt1 addNewVersionBasedOn: '1' asVersion; yourself If you add 2 new versions based on the same version, a branch will be started: VersionHistory startingAt1 addNewVersionBasedOn: '1' asVersion; addNewVersionBasedOn: '1' asVersion; yourself To remove a single version (note: only versions at the tip of a branch, or at the base of the trunk (if it has only one successor) can be individually removed): VersionHistory startingAt1 addNewVersionBasedOn: '1' asVersion; addNewVersionBasedOn: '1' asVersion; remove: '1.1' asVersion; yourself To remove an entire branch: VersionHistory startingAt1 addNewVersionBasedOn: '1' asVersion; addNewVersionBasedOn: '1' asVersion; addNewVersionBasedOn: '1.1' asVersion; addNewVersionBasedOn: '1.2' asVersion; removeBranch: '1.1' asVersion; yourself To remove a portion of the trunk: VersionHistory startingAt1 addNewVersionBasedOn: '1' asVersion; addNewVersionBasedOn: '2' asVersion; addNewVersionBasedOn: '3' asVersion; addNewVersionBasedOn: '3' asVersion; removeTrunk: '2' asVersion; yourself To get a string description of a version history: VersionHistory startingAt1 addNewVersionBasedOn: '1' asVersion; addNewVersionBasedOn: '2' asVersion; addNewVersionBasedOn: '3' asVersion; addNewVersionBasedOn: '3' asVersion; treeString Also, the following methods are useful for accessing the versions: #firstVersion #versionBefore: #versionsAfter: #mainLineStartingAt: #allVersionsAfter: #allVersionsBefore: ! ----- Method: VersionHistory class>>startingAt1 (in category 'as yet unclassified') ----- startingAt1 ^self startingAt: '1' asVersion! ----- Method: VersionHistory class>>startingAt: (in category 'as yet unclassified') ----- startingAt: aVersion ^self new initializeVersionsAt: aVersion; yourself! ----- Method: VersionHistory>>addNewVersionBasedOn: (in category 'adding') ----- addNewVersionBasedOn: aVersion | tmp | (versions includes: aVersion) ifFalse: [^self error: 'Version is not in this history']. tmp := aVersion next. (versions includes: tmp) ifFalse: [versions add: tmp. ^tmp]. tmp := aVersion. [versions includes: (tmp := tmp branchNext)] whileTrue. versions add: tmp. ^tmp ! ----- Method: VersionHistory>>allVersionsAfter: (in category 'accessing') ----- allVersionsAfter: aVersion "Answer all the versions based on aVersion." | answer | answer := Set new. versions do: [ :ea | ((ea inSameBranchAs: aVersion) and: [ea > aVersion]) ifTrue: [answer add: ea]]. ^answer! ----- Method: VersionHistory>>allVersionsBefore: (in category 'accessing') ----- allVersionsBefore: aVersion "Answer all versions that came before aVersion" | answer | answer := Set new. versions do: [ :ea | ((ea inSameBranchAs: aVersion) and: [ea < aVersion]) ifTrue: [answer add: ea]]. ^answer! ----- Method: VersionHistory>>canRemove: (in category 'testing') ----- canRemove: aVersion | hasPriors followers | (versions includes: aVersion) ifFalse: [^false]. hasPriors := (self versionBefore: aVersion) notNil. followers := self versionsAfter: aVersion. "Don't allow versions in the middle to be extracted" (hasPriors and: [followers size > 0]) ifTrue: [^false]. "Don't allow versions with more than one follower to be extracted" (hasPriors not and: [followers size > 1]) ifTrue: [^false]. ^true ! ----- Method: VersionHistory>>firstVersion (in category 'accessing') ----- firstVersion "Answer the first version in the entire version history" ^versions inject: versions anyOne into: [ :x :ea | (x inSameBranchAs: ea) ifTrue: [(x < ea) ifTrue: [x] ifFalse: [ea]] ifFalse: [ea]]! ----- Method: VersionHistory>>includesVersion: (in category 'testing') ----- includesVersion: aVersion ^versions includes: aVersion! ----- Method: VersionHistory>>initializeVersionsAt: (in category 'initialization') ----- initializeVersionsAt: aVersion versions := Set new. versions add: aVersion.! ----- Method: VersionHistory>>mainLineStartingAt: (in category 'accessing') ----- mainLineStartingAt: aVersion "Answer all versions based on aVersion that are not branches (they have the same number of digits with the same values, except the last value is greater than the last value of aVersion)." | answer tmp | answer := OrderedCollection new. tmp := aVersion. [versions includes: tmp] whileTrue: [answer add: tmp. tmp := tmp next]. ^answer ! ----- Method: VersionHistory>>remove: (in category 'removing') ----- remove: aVersion "Remove aVersion from this version history." ^self remove: aVersion ifAbsent: [self error: 'version not found'].! ----- Method: VersionHistory>>remove:ifAbsent: (in category 'removing') ----- remove: aVersion ifAbsent: aBlock "Remove aVersion from this version history." (versions includes: aVersion) ifFalse: [^aBlock value]. (self canRemove: aVersion) ifFalse: [^self error: 'Only versions at the beginning or end with no more than one follower may be removed']. versions remove: aVersion.! ----- Method: VersionHistory>>removeBranch: (in category 'removing') ----- removeBranch: aVersion "Remove aVersion and all of it's successors, providing that aVersion is not the first version." (self versionBefore: aVersion) ifNil: [^self error: 'version is the first version in the history']. versions removeAll: (self allVersionsAfter: aVersion). versions remove: aVersion.! ----- Method: VersionHistory>>removeTrunk: (in category 'removing') ----- removeTrunk: aVersion "Remove aVersion and all of it's predecessors, providing there are no other branches stemming from the trunk. Note, a trunk is defined as all versions, starting with the first version, that have only one successor." | tmp | (self versionsAfter: aVersion) size > 1 ifTrue: [^self error: 'version is at a fork']. tmp := self allVersionsBefore: aVersion. (tmp anySatisfy: [ :ea | (self versionsAfter: ea) size > 1 ]) ifTrue: [^self error: 'not a trunk, other branches detected']. versions removeAll: tmp. versions remove: aVersion.! ----- Method: VersionHistory>>treeString (in category 'printing') ----- treeString "Answer a string that show the entire version history with each branch starting on a new line" ^self treeStringStartingAt: self firstVersion! ----- Method: VersionHistory>>treeStringOn:startingAt: (in category 'printing') ----- treeStringOn: strm startingAt: aVersion | tmp | tmp := self mainLineStartingAt: aVersion. tmp do: [ :ea | ea versionStringOn: strm. strm space; space ]. strm cr. tmp do: [ :ea | (versions includes: ea branchNext) ifTrue: [self treeStringOn: strm startingAt: ea branchNext]].! ----- Method: VersionHistory>>treeStringStartingAt: (in category 'printing') ----- treeStringStartingAt: aVersion | strm | strm := WriteStream on: ''. self treeStringOn: strm startingAt: aVersion. ^strm contents! ----- Method: VersionHistory>>versionBefore: (in category 'accessing') ----- versionBefore: aVersion "Answer the version immediately preceeding aVersion." | tmp | (aVersion > '1' asVersion) ifFalse: [^nil]. (versions includes: (tmp := aVersion previous)) ifFalse: [^nil]. ^tmp! ----- Method: VersionHistory>>versionsAfter: (in category 'accessing') ----- versionsAfter: aVersion "Answer all the versions immediately following aVersion." | answer tmp | answer := Set new. tmp := aVersion next. (versions includes: aVersion next) ifTrue: [answer add: tmp]. tmp := aVersion. [versions includes: (tmp := tmp branchNext)] whileTrue: [answer add: tmp]. ^answer! ----- Method: String>>asVersion (in category '*versionnumber') ----- asVersion "Answer a VersionNumber" ^VersionNumber fromString: self!

1 0

Squeak 4.6: SmallLand-ColorTheme-fbs.6.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of SmallLand-ColorTheme to project Squeak 4.6: http://source.squeak.org/squeak46/SmallLand-ColorTheme-fbs.6.mcz ==================== Summary ==================== Name: SmallLand-ColorTheme-fbs.6 Author: fbs Time: 31 December 2013, 2:14:02.015 pm UUID: a78b81e3-3b11-c24e-9c84-3bb5319e0858 Ancestors: SmallLand-ColorTheme-nice.5 Remove references to preferences that are now pragma based. ==================== Snapshot ==================== SystemOrganization addCategory: #'SmallLand-ColorTheme'! ----- Method: Preferences class>>smallLand (in category '*SmallLand-ColorTheme') ----- smallLand "Small-Land theme. It install the complete Small-Land theme (Preferences, Fonts, Colors, etc)" " Preferences smallLand. " self smallLandPreferences. self smallLandFonts. SmallLandColorTheme current apply! ----- Method: Preferences class>>smallLandBigFonts (in category '*SmallLand-ColorTheme') ----- smallLandBigFonts "private - change the fonts to small-land's choices" " Preferences smallLandBigFonts. " #( (setButtonFontTo: #BitstreamVeraSansMono 15) (setListFontTo: #BitstreamVeraSans 15) (setMenuFontTo: #BitstreamVeraSans 15) (setSystemFontTo: #BitstreamVeraSans 15) (setWindowTitleFontTo: #BitstreamVeraSans 15) (setCodeFontTo: #BitstreamVeraSerif 15) (setFlapsFontTo: #KomikaText 24) (setEToysFontTo: #KomikaText 24) (setHaloLabelFontTo: #KomikaText 24) (setEToysTitleFontTo: #KomikaText 36) ) do: [:triplet | Preferences perform: triplet first with: (StrikeFont familyName: triplet second pointSize: triplet third) ]. BalloonMorph setBalloonFontTo: (StrikeFont familyName: #BitstreamVeraSans pointSize: 15). ! ----- Method: Preferences class>>smallLandFonts (in category '*SmallLand-ColorTheme') ----- smallLandFonts "private - change the fonts to small-land's choices" " Preferences smallLandFonts. " Preferences bigDisplay ifTrue: [^ self smallLandBigFonts]. Preferences tinyDisplay ifTrue: [^ self smallLandTinyFonts]. self smallLandSmallFonts! ----- Method: Preferences class>>smallLandPreferences (in category '*SmallLand-ColorTheme') ----- smallLandPreferences "Private - change the preferences according to small-land taste" self setPreferencesFrom: #( (haloEnclosesFullBounds true) (showBoundsInHalo true) (cmdGesturesEnabled false) (easySelection true) (abbreviatedBrowserButtons true) (alternativeBrowseIt true) (alwaysShowVScrollbar false) (annotationPanes true) (balloonHelpInMessageLists true) (classicNewMorphMenu true) (collapseWindowsInPlace true) (diffsWithPrettyPrint true) (dragNDropWithAnimation true) (duplicateControlAndAltKeys true) (eToyFriendly true) (extraDebuggerButtons true) (extractFlashInHighestQuality true) (fastDragWindowForMorphic false) (includeSoundControlInNavigator true) (menuKeyboardControl true) (menuAppearance3d false) (gradientMenu false) (mouseOverForKeyboardFocus true) (optionalButtons true) (projectViewsInWindows true) (propertySheetFromHalo true) (scrollBarsNarrow true) (scrollBarsOnRight true) (selectiveHalos true) (showDirectionForSketches true) (showDirectionHandles true) (translationWithBabel true) (unlimitedPaintArea true) (unlimitedPaintArea true) (menuColorFromWorld false) (noviceMode true) (uniqueNamesInHalos true) (infiniteUndo true) (useUndo true) (soundStopWhenDone true) ). self setParameter: #balloonHelpDelayTime to: 100. ! ----- Method: Preferences class>>smallLandSmallFonts (in category '*SmallLand-ColorTheme') ----- smallLandSmallFonts "private - change the fonts to small-land's choices" " Preferences smallLandFonts. " #( (setButtonFontTo: #BitstreamVeraSansMono 12) (setListFontTo: #BitstreamVeraSans 12) (setMenuFontTo: #BitstreamVeraSans 12) (setSystemFontTo: #BitstreamVeraSans 12) (setWindowTitleFontTo: #BitstreamVeraSans 15) (setCodeFontTo: #BitstreamVeraSerif 12) (setFlapsFontTo: #KomikaText 15) (setEToysFontTo: #KomikaText 15) (setHaloLabelFontTo: #KomikaText 15) (setEToysTitleFontTo: #KomikaText 24) ) do: [:triplet | Preferences perform: triplet first with: (StrikeFont familyName: triplet second pointSize: triplet third) ]. BalloonMorph setBalloonFontTo: (StrikeFont familyName: #BitstreamVeraSans pointSize: 12). ! ----- Method: Preferences class>>smallLandTinyFonts (in category '*SmallLand-ColorTheme') ----- smallLandTinyFonts "private - change the fonts to small-land's choices" " Preferences smallLandTinyFonts. " #( (setButtonFontTo: #AccujenMono 9) (setListFontTo: #Accujen 9) (setMenuFontTo: #Accujen 9) (setSystemFontTo: #Accujen 9) (setWindowTitleFontTo: #Accujen 10) (setCodeFontTo: #Accuny 9) (setFlapsFontTo: #Atlanta 11) (setEToysFontTo: #Atlanta 11) (setHaloLabelFontTo: #Atlanta 11) (setEToysTitleFontTo: #Atlanta 11) ) do: [:triplet | Preferences perform: triplet first with: (StrikeFont familyName: triplet second pointSize: triplet third) ]. BalloonMorph setBalloonFontTo: (StrikeFont familyName: #Accujen pointSize: 9). ! ColorTheme subclass: #SmallLandColorTheme instanceVariableNames: 'darks normals lights' classVariableNames: '' poolDictionaries: '' category: 'SmallLand-ColorTheme'! SmallLandColorTheme subclass: #BlueSmallLandColorTheme instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SmallLand-ColorTheme'! ----- Method: BlueSmallLandColorTheme>>baseColors (in category 'initialization') ----- baseColors " BlueSmallLandColorTheme apply. " ^ Array with: (Color fromArray: #(0.2 0.3 0.9 )) with: (Color fromArray: #(0.6 0.7 1.0 )) with: (Color fromArray: #(0.85 0.9 1.0 ))! SmallLandColorTheme subclass: #GraySmallLandColorTheme instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SmallLand-ColorTheme'! ----- Method: GraySmallLandColorTheme>>baseColors (in category 'initialization') ----- baseColors " GraySmallLandColorTheme apply. " ^ Array with: (Color fromArray: #(0.4 0.4 0.4 )) with: (Color fromArray: #(0.8 0.8 0.8 )) with: (Color fromArray: #(0.97 0.97 0.97 ))! SmallLandColorTheme subclass: #GreenSmallLandColorTheme instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SmallLand-ColorTheme'! ----- Method: GreenSmallLandColorTheme>>baseColors (in category 'initialize-release') ----- baseColors " GreenSmallLandColorTheme apply. " ^ Array with: (Color fromArray: #(0.1 0.5 0.3 )) with: (Color fromArray: #(0.2 0.9 0.6 )) with: (Color fromArray: #(0.85 1.0 0.98 ))! SmallLandColorTheme subclass: #MagentaSmallLandColorTheme instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SmallLand-ColorTheme'! ----- Method: MagentaSmallLandColorTheme>>baseColors (in category 'initialization') ----- baseColors " MagentaSmallLandColorTheme apply. " ^ Array with: (Color fromArray: #(0.8 0.1 0.7 )) with: (Color fromArray: #(1.0 0.3 0.9 )) with: (Color fromArray: #(1.0 0.9 0.8 ))! SmallLandColorTheme subclass: #OrangeSmallLandColorTheme instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SmallLand-ColorTheme'! ----- Method: OrangeSmallLandColorTheme>>baseColors (in category 'initialization') ----- baseColors " OrangeSmallLandColorTheme apply. " ^ Array with: (Color fromArray: #(0.8 0.4 0.0 )) with: (Color fromArray: #(1.0 0.8 0.0 )) with: (Color fromArray: #(1.0 1.0 0.8 ))! SmallLandColorTheme subclass: #RedSmallLandColorTheme instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SmallLand-ColorTheme'! ----- Method: RedSmallLandColorTheme>>baseColors (in category 'initialization') ----- baseColors " RedSmallLandColorTheme apply. " ^ Array with: (Color fromArray: #(0.8 0.0 0.2 )) with: (Color fromArray: #(0.97 0.13 0.3 )) with: (Color fromArray: #(1.0 0.88 0.97 ))! ----- Method: SmallLandColorTheme class>>allThemes (in category 'accessing') ----- allThemes " SmallLandColorTheme allThemes. " ^ self withAllSubclasses reject: [:each | each == self]! ----- Method: SmallLandColorTheme class>>chooseTheme (in category 'accessing') ----- chooseTheme " SmallLandColorTheme chooseTheme. " | themes menu | menu := MenuMorph new defaultTarget: self. menu addTitle: 'choose color theme' translated. Preferences noviceMode ifFalse: [menu addStayUpItem]. "" themes := self allThemes asSortedCollection: [:x :y | x themeName translated <= y themeName translated]. themes do: [:each | ""menu addUpdating: #stringForTheme: target: each selector: #applyTheme: argumentList: {each}]. "" menu popUpInWorld! ----- Method: SmallLandColorTheme class>>stringForTheme: (in category 'accessing') ----- stringForTheme: aTheme ^ (aTheme == ColorTheme current class ifTrue: ['<on>'] ifFalse: ['<off>']) , aTheme themeName translated.! ----- Method: SmallLandColorTheme class>>themeName (in category 'accessing') ----- themeName " self themeName. BlueSmallLandColorTheme themeName. GreenSmallLandColorTheme themeName. " ^ self name allButLast: 'SmallLandColorTheme' size. ! ----- Method: SmallLandColorTheme class>>unload (in category 'as yet unclassified') ----- unload ColorTheme current: ColorTheme defaultTheme.! ----- Method: SmallLandColorTheme>>apply (in category 'applying') ----- apply Preferences installBrightWindowColors. "" super apply. "" self updateTopProject. self updateFlaps. self updateWorldMainDockingBar! ----- Method: SmallLandColorTheme>>balloonColor (in category 'theme') ----- balloonColor ^ (self light: 1) twiceLighter alpha: 0.95"Color white alpha: 0.95"! ----- Method: SmallLandColorTheme>>baseColors (in category 'initialization') ----- baseColors "Answer a collection of the 3 base colors" ^ self subclassResponsibility! ----- Method: SmallLandColorTheme>>cancelColor (in category 'theme') ----- cancelColor ^ super cancelColor"self normal: 8"! ----- Method: SmallLandColorTheme>>dark: (in category 'private - colors') ----- dark: index ^ darks at: index! ----- Method: SmallLandColorTheme>>defaultWorldColor (in category 'theme') ----- defaultWorldColor ^ (self light: 1) twiceLighter twiceLighter ! ----- Method: SmallLandColorTheme>>dialog3DTitles (in category 'theme - dialogs') ----- dialog3DTitles ^ false! ----- Method: SmallLandColorTheme>>dialogBorderColor (in category 'theme - dialogs') ----- dialogBorderColor ^ (self dark: 5) ! ----- Method: SmallLandColorTheme>>dialogBorderWidth (in category 'theme - dialogs') ----- dialogBorderWidth ^ 2! ----- Method: SmallLandColorTheme>>dialogButtonBorderWidth (in category 'theme - dialogs') ----- dialogButtonBorderWidth ^ 1! ----- Method: SmallLandColorTheme>>dialogColor (in category 'theme - dialogs') ----- dialogColor ^ self light: 3! ----- Method: SmallLandColorTheme>>dialogPaneBorderColor (in category 'theme - dialogs') ----- dialogPaneBorderColor ^ self dialogTextBoxBorderColor ! ----- Method: SmallLandColorTheme>>dialogPaneBorderWidth (in category 'theme - dialogs') ----- dialogPaneBorderWidth ^ 1! ----- Method: SmallLandColorTheme>>dialogPaneRampOrColor (in category 'theme - dialogs') ----- dialogPaneRampOrColor ^ self dialogTextBoxColor! ----- Method: SmallLandColorTheme>>dialogRampOrColor (in category 'theme - dialogs') ----- dialogRampOrColor ^ self dialogColor! ----- Method: SmallLandColorTheme>>dialogTextBoxBorderColor (in category 'theme - dialogs') ----- dialogTextBoxBorderColor ^ self normal: 1! ----- Method: SmallLandColorTheme>>dialogTextBoxColor (in category 'theme - dialogs') ----- dialogTextBoxColor ^ self light: 1! ----- Method: SmallLandColorTheme>>dockingBarAutoGradient (in category 'theme - dockingbar') ----- dockingBarAutoGradient ^ true! ----- Method: SmallLandColorTheme>>dockingBarColor (in category 'theme - dockingbar') ----- dockingBarColor ^self normal:1! ----- Method: SmallLandColorTheme>>dockingBarGradientRamp (in category 'theme - dockingbar') ----- dockingBarGradientRamp ^ {0.0 -> Color white. 1.0 -> (self normal:1)}! ----- Method: SmallLandColorTheme>>helpColor (in category 'theme') ----- helpColor ^ self okColor! ----- Method: SmallLandColorTheme>>initialize (in category 'initialization') ----- initialize "Initialize the receiver" | baseColors | super initialize. "" baseColors := self baseColors. "" darks := baseColors first wheel: 8. normals := baseColors second wheel: 8. lights := baseColors third wheel: 8! ----- Method: SmallLandColorTheme>>insertionPointColor (in category 'theme') ----- insertionPointColor ^ self normal: 7! ----- Method: SmallLandColorTheme>>keyboardFocusColor (in category 'theme') ----- keyboardFocusColor ^ self normal: 8! ----- Method: SmallLandColorTheme>>labelForColor: (in category 'private - colors') ----- labelForColor: aColor ^ (aColor red printShowingMaxDecimalPlaces: 2) , ' ' , (aColor green printShowingMaxDecimalPlaces: 2) , ' ' , (aColor blue printShowingMaxDecimalPlaces: 2)! ----- Method: SmallLandColorTheme>>light: (in category 'private - colors') ----- light: index ^ lights at: index! ----- Method: SmallLandColorTheme>>menuBorderColor (in category 'theme - menus') ----- menuBorderColor ^self dark: 1! ----- Method: SmallLandColorTheme>>menuBorderWidth (in category 'theme - menus') ----- menuBorderWidth ^ 2.! ----- Method: SmallLandColorTheme>>menuColor (in category 'theme - menus') ----- menuColor ^ self light: 1! ----- Method: SmallLandColorTheme>>menuLineColor (in category 'theme - menus') ----- menuLineColor ^ self normal: 1! ----- Method: SmallLandColorTheme>>menuSelectionColor (in category 'theme - menus') ----- menuSelectionColor ^ self dark: 1! ----- Method: SmallLandColorTheme>>menuTitleBorderColor (in category 'theme - menus') ----- menuTitleBorderColor ^ self menuTitleColor ! ----- Method: SmallLandColorTheme>>menuTitleBorderWidth (in category 'theme - menus') ----- menuTitleBorderWidth ^ 6! ----- Method: SmallLandColorTheme>>menuTitleColor (in category 'theme - menus') ----- menuTitleColor ^ self normal: 1! ----- Method: SmallLandColorTheme>>normal: (in category 'private - colors') ----- normal: index ^ normals at: index! ----- Method: SmallLandColorTheme>>okColor (in category 'theme') ----- okColor ^ super okColor "self normal: 2"! ----- Method: SmallLandColorTheme>>printOn: (in category 'printing') ----- printOn: aStream aStream nextPutAll: 'Small-Land Color Theme: ', self class themeName! ----- Method: SmallLandColorTheme>>rowOf: (in category 'private - colors') ----- rowOf: colors | row | row := AlignmentMorph newRow. row cellInset: 5. row color: Color white. "" colors do: [:each | | box label | box := RectangleMorph new. box extent: 100 @ 60. box color: each. box borderWidth: 2. box borderColor: box color muchDarker. "" label := StringMorph contents: (self labelForColor: each). label color: each negated. box addMorphCentered: label. "" row addMorphBack: box]. "" ^ row ! ----- Method: SmallLandColorTheme>>showColors (in category 'private - colors') ----- showColors " BlueSmallLandColorTheme new showColors. " | col | col := AlignmentMorph newColumn. col color: Color white. col addMorphBack: (self rowOf: darks). col addMorphBack: (self rowOf: normals). col addMorphBack: (self rowOf: lights). "" col openInWorld! ----- Method: SmallLandColorTheme>>textHighlightColor (in category 'theme') ----- textHighlightColor ^self normal: 1! ----- Method: SmallLandColorTheme>>updateFlaps (in category 'applying') ----- updateFlaps Flaps globalFlapTabs select: [:each | each flapID = 'Supplies' translated] thenDo: [:each | each color: (self normal: 1); borderColor: (self normal: 1); borderWidth: (self menuBorderWidth). "" each referent color: (self light: 1); borderWidth: (self menuBorderWidth); borderColor: (self normal: 1)]! ----- Method: SmallLandColorTheme>>updateTopProject (in category 'applying') ----- updateTopProject Project current == Project topProject ifFalse:[^ self]. "" World color: Preferences defaultWorldColor. World submorphs select: [:each | "" (each isKindOf: StringMorph) and: [each contents = 'Squeak']] thenDo: [:each | each color: (self dark: 1)]. ! ----- Method: SmallLandColorTheme>>updateWorldMainDockingBar (in category 'applying') ----- updateWorldMainDockingBar | oldPreference | oldPreference := Project current showWorldMainDockingBar. "" Project current showWorldMainDockingBar: false. Project current showWorldMainDockingBar: oldPreference. TheWorldMainDockingBar updateInstances! SmallLandColorTheme subclass: #VioletSmallLandColorTheme instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SmallLand-ColorTheme'! ----- Method: VioletSmallLandColorTheme>>baseColors (in category 'as yet unclassified') ----- baseColors " VioletSmallLandColorTheme apply. " ^ Array with: (Color fromArray: #(0.6 0.0 1.0 )) with: (Color fromArray: #(0.8 0.4 1.0 )) with: (Color fromArray: #(0.95 0.95 1.0 ))! SmallLandColorTheme subclass: #YellowSmallLandColorTheme instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SmallLand-ColorTheme'! ----- Method: YellowSmallLandColorTheme>>baseColors (in category 'initialization') ----- baseColors " YellowSmallLandColorTheme apply. " ^ Array with: (Color fromArray: #(0.6 0.6 0.0 )) with: (Color fromArray: #(0.9 0.9 0.3 )) with: (Color fromArray: #(1.0 1.0 0.9 ))!

1 0

Squeak 4.6: HelpSystem-Tests-mt.16.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of HelpSystem-Tests to project Squeak 4.6: http://source.squeak.org/squeak46/HelpSystem-Tests-mt.16.mcz ==================== Summary ==================== Name: HelpSystem-Tests-mt.16 Author: mt Time: 25 March 2015, 11:30:13.168 am UUID: 7a2dcc3a-6e0b-0d47-bccf-0b1bbd056a66 Ancestors: HelpSystem-Tests-fbs.15 Tests updated. ==================== Snapshot ==================== SystemOrganization addCategory: #'HelpSystem-Tests-Builders'! SystemOrganization addCategory: #'HelpSystem-Tests-Core-Model'! SystemOrganization addCategory: #'HelpSystem-Tests-Core-UI'! TestCase subclass: #ClassAPIHelpBuilderTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Tests-Builders'! ----- Method: ClassAPIHelpBuilderTest>>testDefaultBuilding (in category 'testing') ----- testDefaultBuilding |topic| topic := CurrentReadOnlySourceFiles cacheDuring: [ ClassAPIHelpBuilder buildHelpTopicFrom: Integer ]. self assert: topic subtopics size = 2. self assert: topic subtopics first title = 'Instance side'. self assert: topic subtopics last title = 'Class side' ! ----- Method: ClassAPIHelpBuilderTest>>testMethodsButNoSubclasses (in category 'testing') ----- testMethodsButNoSubclasses |topic| topic := CurrentReadOnlySourceFiles cacheDuring: [ ClassAPIHelpBuilder buildHierarchicalHelpTopicFrom: Integer withSubclasses: false withMethods: true ]. self assert: topic subtopics size = 2. self assert: topic subtopics first title = 'Instance side'. self assert: topic subtopics last title = 'Class side' ! TestCase subclass: #HelpBrowserTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Tests-Core-UI'! ----- Method: HelpBrowserTest>>defaultTestClass (in category 'accessing') ----- defaultTestClass ^HelpBrowser! ----- Method: HelpBrowserTest>>testDefaultHelpBrowser (in category 'testing') ----- testDefaultHelpBrowser | current replacement instance | current := self defaultTestClass defaultHelpBrowser. replacement := AdvancedHelpBrowserDummy. [ self defaultTestClass defaultHelpBrowser: replacement. self assert: self defaultTestClass defaultHelpBrowser == replacement. instance := self defaultTestClass open. self assert: instance rootTopic notNil. self assert: instance isOpen. ] ensure: [ self defaultTestClass defaultHelpBrowser: current ] ! ----- Method: HelpBrowserTest>>testDefaultHelpBrowserIsReplacable (in category 'testing') ----- testDefaultHelpBrowserIsReplacable | current replacement instance | "save the one that is registered" current := self defaultTestClass defaultHelpBrowser. replacement := AdvancedHelpBrowserDummy. [ self defaultTestClass defaultHelpBrowser: replacement. self assert: self defaultTestClass defaultHelpBrowser == replacement. instance := self defaultTestClass open. ] ensure: [ self defaultTestClass defaultHelpBrowser: current ] ! ----- Method: HelpBrowserTest>>testLazyDefaultHelpBrowser (in category 'testing') ----- testLazyDefaultHelpBrowser self assert: self defaultTestClass defaultHelpBrowser notNil! ----- Method: HelpBrowserTest>>testOpen (in category 'testing') ----- testOpen |browser| "This should not throw an exception." browser := self defaultTestClass open. World doOneCycleNow. browser changed: #close.! ----- Method: HelpBrowserTest>>testRegistration (in category 'testing') ----- testRegistration TheWorldMenu registeredOpenCommands detect: [:each | each first = 'Help Browser'] ifNone: [self fail]. ! TestCase subclass: #HelpIconsTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Tests-Core-UI'! ----- Method: HelpIconsTest>>defaultTestClass (in category 'accessing') ----- defaultTestClass ^HelpIcons! ----- Method: HelpIconsTest>>testIconCaching (in category 'testing') ----- testIconCaching | first second | #(bookIcon pageIcon refreshIcon) do: [:iconSymbol | first := self defaultTestClass iconNamed: iconSymbol. second := self defaultTestClass iconNamed: iconSymbol. self assert: first notNil. self assert: first == second. ] ! TestCase subclass: #HelpTopicListItemWrapperTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Tests-Core-UI'! ----- Method: HelpTopicListItemWrapperTest>>defaultTestClass (in category 'accessing') ----- defaultTestClass ^HelpTopicListItemWrapper ! ----- Method: HelpTopicListItemWrapperTest>>testDisplayLabel (in category 'testing') ----- testDisplayLabel |instance| instance := self defaultTestClass with: (HelpTopic named: 'My Topic'). self assert: instance asString = 'My Topic' ! TestCase subclass: #HelpTopicTest instanceVariableNames: 'topic' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Tests-Core-Model'! ----- Method: HelpTopicTest>>defaultTestClass (in category 'accessing') ----- defaultTestClass ^HelpTopic ! ----- Method: HelpTopicTest>>setUp (in category 'running') ----- setUp super setUp. topic := self defaultTestClass new.! ----- Method: HelpTopicTest>>testAddingSubtopic (in category 'testing') ----- testAddingSubtopic |subtopic returned| subtopic := self defaultTestClass named: 'Subtopic'. returned := topic addSubtopic: subtopic. self assert: returned == subtopic. self assert: (topic subtopics includes: subtopic) ! ----- Method: HelpTopicTest>>testInitialization (in category 'testing') ----- testInitialization self assert: topic title = 'Unnamed Topic'. self assert: topic contents isEmpty ! ----- Method: HelpTopicTest>>testInstanceCreation (in category 'testing') ----- testInstanceCreation |instance| instance := self defaultTestClass named: 'My Topic'. self assert: instance title = 'My Topic'. ! ----- Method: HelpTopicTest>>testSortOrder (in category 'testing') ----- testSortOrder |a b c sorted | a := self defaultTestClass named: 'A'. b := self defaultTestClass named: 'B'. c := self defaultTestClass named: 'C'. sorted := (OrderedCollection with: b with: c with: a) asSortedCollection. self assert: sorted first = a. self assert: sorted last = c. ! Object subclass: #AdvancedHelpBrowserDummy instanceVariableNames: 'rootTopic isOpen' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Tests-Core-UI'! !AdvancedHelpBrowserDummy commentStamp: 'tbn 5/3/2010 19:30' prior: 0! This is a dummy for a custom Help browser that can be registered as a replacement for the HelpBrowser class. Instance Variables rootTopic: <HelpTopic> rootTopic - The root help topic ! ----- Method: AdvancedHelpBrowserDummy>>initialize (in category 'initialize-release') ----- initialize isOpen := false! ----- Method: AdvancedHelpBrowserDummy>>isOpen (in category 'testing') ----- isOpen ^isOpen! ----- Method: AdvancedHelpBrowserDummy>>open (in category 'mocking') ----- open isOpen := true! ----- Method: AdvancedHelpBrowserDummy>>rootTopic (in category 'mocking') ----- rootTopic ^rootTopic! ----- Method: AdvancedHelpBrowserDummy>>rootTopic: (in category 'mocking') ----- rootTopic: aTopic rootTopic := aTopic!

1 0

← Newer
1
...
7
8
9
10
11
12
13
...
17
Older →

Jump to page: